|
新版的代码缩进的问题,比上个版本还难受
- Dim K11 As Integer, K12 As Integer, K13 As Integer, K14 As Integer
- Dim T10 As String, T11 As String, T12 As String, T13 As String, T14 As String, T15 As String
- Dim T16 As String, T17 As String, T18 As String, T19 As String, T20 As String
- Dim T21 As String, T22 As String, T23 As String
- Dim T31 As String, T32 As String, T33 As String, T34 As String, T35 As String, T36 As String
- Dim K71 As Integer, K72 As Integer
- Dim i As Integer, j As Integer, L As Integer
- Dim K_AwbRow As Integer, K_TwbRow As Integer
- Dim T_End As String, T_Sht As String, T_TwbSht As String, T_Fgf As String
- Dim U_1 As String, U_2 As String
- Dim Arr As Variant, Brr As Variant, Crr As Variant
- Dim Crr1() As String, Crr2() As String
- Dim Dic As Object, Dic1 As Object
- Set Dic = CreateObject("Scripting.Dictionary")
- Set Dic1 = CreateObject("Scripting.Dictionary")
- T_Sht = "基础信息": T_TwbSht = "序时过度" '第一次较固定常量赋值
- U_1 = "R1": T_Fgf = "|": K71 = 30
- With ThisWorkbook.Sheets(T_Sht)
- Brr = .Range(U_1).CurrentRegion
- K11 = LBound(Brr, 2) + 1
- K12 = UBound(Brr, 2) - 1
- For L = K12 To K11 Step -1
- If L <> 3 Then
- If L = K12 Then
- Arr = ThisWorkbook.Sheets(T_TwbSht).Range("a1").CurrentRegion.Value
-
- T10 = "【导出表-4列-"
- K_AwbRow = Brr(2, 1) '导入表标题行 K_AwbRow
- T11 = UBound(Arr, 2) '导出表最大列 确定Crr1()最大列
- ElseIf L = K11 Then
- On Error Resume Next
- U_1 = Environ("USERPROFILE") & "\Desktop"
- ChDrive Left(U_1, 1)
- ChDir U_1
- If Err.Number <> 0 Then
- U_1 = Environ("USERPROFILE") & "\桌面"
- ChDrive Left(U_1, 1)
- ChDir U_1
- If Err.Number <> 0 Then
- U_1 = ThisWorkbook.Path
- ChDrive Left(U_1, 1)
- ChDir U_1
- End If
- End If
- On Error GoTo 0
-
- Fil = Application.GetOpenFilename(filefilter:="Excel文件,*.xls*,所有文件,*.*")
- If Fil = False Then
- MsgBox "没有选择任何文件!"
- Exit Sub
- Else
- t = Timer
- Workbooks.Open Fil
- Arr = ActiveSheet.Range("a1").CurrentRegion.Value '导出序时账导入数组arr
- ActiveWorkbook.Close
- End If
- 't = Timer '改代码使用
- 'Workbooks.Open "D:\工作文档\3-报表帐套\2020年决算\2020序时账.xls"
- 'Arr = ActiveSheet.Range("a1").CurrentRegion.Value
- 'ActiveWorkbook.Close
-
- T10 = "【打开表-2列-"
- K_AwbRow = Brr(1, 1) '导入表标题行 K_AwbRow
- End If
-
- For i = LBound(Arr, 2) To UBound(Arr, 2) Step 1
- U_1 = Arr(K_AwbRow, i)
- If Len(U_1) > 0 Then
- If Not Dic.Exists(U_1) Then
- Dic(U_1) = i
- Else
- For j = 2 To K71 Step 1
- U_2 = U_1 & T_Fgf & j
- If Not Dic.Exists(U_2) Then Dic(U_2) = i: Exit For
- Next j
- End If
- End If
- Next i
-
- If L = K12 Then
- K_TwbRow = UBound(Brr, 2)
- ElseIf L = K11 Then
- K_TwbRow = LBound(Brr, 2)
- End If
-
- K_AwbRow = 0: U_2 = "【Column】" '分隔符临时赋值 U_2
- For i = LBound(Brr, 1) To UBound(Brr, 1) Step 1
- U_1 = Brr(i, 3)
- If InStr(1, U_1, U_2, vbTextCompare) > 0 Then
- If K_AwbRow = 0 Then K_AwbRow = i
- U_1 = Brr(i, L)
- If Len(U_1) > 0 Then
- If Dic.Exists(U_1) Then
- If Brr(i, K_TwbRow) <> Dic(U_1) Then
- T_End = Chr(10) & T10 & U_1 & ",修正为-" & Dic(U_1) & "-列】" & T_End
- Brr(i, K_TwbRow) = Dic(U_1)
- End If
- Else
- T_End = Chr(10) & T10 & U_1 & ",请核对名称!】" & T_End
- End If
- End If
- End If
- Next i
- End If
- Dic.RemoveAll
- Next L
- End With
- End Sub
复制代码 |
|