VBA 格式化excel数据表 （数据分列）

Sub ImportData()
'
' Copy  Data from one workbook to the Current Workbook
' Place the macro file in the same folder as the source file
'
    
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    Application.ScreenUpdating = False
    thrn = ThisWorkbook.Sheets(1).Range("A100000").Row
    With ThisWorkbook.Sheets(1)
        .Range("A1:T" & thrn).ClearContents
    End With
    Do While f <> ""
        
            If f <> ThisWorkbook.Name Then
                Set wb = GetObject(p & f)
                With wb.Sheets(1)
                  rn = .Range("A100000").End(xlUp).Row
                  ThisWorkbook.Sheets(1).Range("A1:T" & rn).Value = .Range("A1:T" & rn).Value
                  MsgBox "Format Complete."
                End With
            End If
            
        f = Dir
    Loop
    
End Sub

Sub Text_to_Columns()
'Formatted Data
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 3), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1)), DecimalSeparator:=".", ThousandsSeparator:=",", _
        TrailingMinusNumbers:=True
    Columns("A:T").Select
    Selection.Copy
End Sub

Sub Copy_Back()
'
' Copy back the formatted data to the source file
'
    
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    Application.ScreenUpdating = False
    thrn = ThisWorkbook.Sheets(1).Range("A100000").Row
  
    Do While f <> ""
        
            If f <> ThisWorkbook.Name Then
                Set wb = GetObject(p & f)
                With wb.Sheets(1)
                    rn = .Range("A100000").End(xlUp).Row
                    .Range("A1:T" & rn).ClearContents
                    .Range("A1:T" & thrn).Value = ThisWorkbook.Sheets(1).Range("A1:T" & thrn).Value
                  MsgBox "Complete."
        
                End With
            End If
            
        f = Dir
    Loop
   ThisWorkbook.Sheets(1).Range("A1:T" & thrn).ClearContents
   wb.Save 'Make sure the source file is already open
   
End Sub

Sub ExecConvert()
'
'Execute Macros
'
    Call ImportData
    Call Text_to_Columns
    Call Copy_Back
End Sub

标签：ThisWorkbook,VBA,End,Sub,excel,数据表,Range,Sheets,Array
来源： https://www.cnblogs.com/luoye00/p/11358409.html