Sub NextSeven_CodeFrame()
'应用程序设置
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual '错误处理
On Error GoTo ErrHandler '计时器
Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer '变量声明
Dim Wb As Workbook
Dim Sht As Worksheet
Dim OpenWb As Workbook
Dim oSht As Worksheet
Dim i&, j& Dim Rng As Range
Dim Arr As Variant
Dim EndRow As Long
Dim RowCount As Long
Dim ColCount As Long Dim FilePath As String '实例化对象
Set Wb = Application.ThisWorkbook '选取单个文件
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = Wb.Path '指定初始化路径
.Filters.Clear
.Filters.Add "Excel文件", "*.xls;*.xlsx"
If .Show = -1 Then
FilePath = .SelectedItems(1)
Else
Exit Sub
End If
End With Set OpenWb = Application.Workbooks.Open(FilePath)
Set oSht = OpenWb.Worksheets(1)
With oSht
Set Rng = Application.Intersect(.UsedRange.Offset(1), .UsedRange)
RowCount = Rng.Rows.Count
ColCount = Rng.Columns.Count
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
'长数字加单引号
Arr(i, 2) = "'" & Arr(i, 2)
Arr(i, 10) = "'" & Arr(i, 10)
Arr(i, 14) = "'" & Arr(i, 14)
Arr(i, 15) = "'" & Arr(i, 15)
Arr(i, 18) = "'" & Arr(i, 18)
'转置关系
Arr(i, 20) = Arr(i, 2)
Arr(i, 2) = Arr(i, 1)
Arr(i, 1) = "" Next i
End With
OpenWb.Close False Set Sht = Wb.Worksheets(1)
With Sht
.UsedRange.Offset(6).Clear '预先清除
Set Rng = .Range("A7").Resize(RowCount, ColCount)
Rng.Value = Arr '导入内容
End With Dim RowStart As Object
Dim RowsCount As Object
Dim Key As String
Dim OneKey As Variant
Set RowStart = CreateObject("scripting.dictionary")
Set RowsCount = CreateObject("scripting.dictionary") MergeColumnNo = 2 '关键字所在列 For i = LBound(Arr, 1) To UBound(Arr, 1)
Key = CStr(Arr(i, MergeColumnNo))
If RowStart.Exists(Key) = False Then
RowStart(Key) = i
RowsCount(Key) = 1
Else
RowsCount(Key) = RowsCount(Key) + 1
End If
Next i MergeCols = Array("A", "B", "D", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Z") '合并列
For Each OneKey In RowStart.Keys
For n = LBound(MergeCols) To UBound(MergeCols)
Rng.Cells(RowStart(OneKey), MergeCols(n)).Resize(RowsCount(OneKey), 1).Merge
Next n
Next OneKey Const HeadRow As Long = 6
Dim Index As Long
With Sht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Index = 0
For i = HeadRow + 1 To EndRow
If .Cells(i, 2).Value <> "" Then
Index = Index + 1
.Cells(i, 1).Value = Index
End If
Next i
End With SetEdges Rng
CustomFormat Rng
Union(Sht.Range("A6:Z6"), Rng).Columns.AutoFit '运行耗时
UsedTime = VBA.Timer - StartTime
MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒") & "——NextSeven竭诚为您服务。"
ErrorExit: '错误处理结束，开始环境清理
Set Wb = Nothing
Set OpenWb = Nothing
Set Sht = Nothing
Set oSht = Nothing
Set Rng = Nothing Set RowStart = Nothing
Set RowsCount = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "错误提示！"
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub
Sub CustomFormat(ByVal Rng As Range)
With Rng
.Font.Name = "宋体"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Sub