将不同工作簿中的多个列复制到彼此相邻的列

Question

我正在尝试从包含 300 个工作簿（名为 001、002 等）的文件夹中提取数据。
我想将每个文件的 G 列中的数据复制到单独的文件夹中。如果 G 列中的数据在每个文件中，则其数量不同。

我已经能够复制数据，但无法让它移过 B 列，而是写入前一列。

需要的输出是：
将工作簿 G 列“001”中的数据粘贴到“新工作表”A 列中
G 列工作簿“002”中的数据粘贴到“新工作表”B 列中
等等

300个文件夹中的每个文件都有一个工作表，每个工作表标记为：001、002、...、300

此代码会产生两列数据，其中一列数据被每个新工作表替换。

Sub Copy()

Dim MyFile As String
Dim Filepath As String
Dim q As Long

Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer

Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1

Filepath = "C:..."

MyFile = Dir(Filepath)

Do While Len(MyFile) > 0
    If MyFile = "Text to column.xlsm" Then
        Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)

    LastRow = Range("G1").CurrentRegion.Rows.Count

    Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))

    ActiveWorkbook.Save
    ActiveWorkbook.Close
    MyFile = Dir
Loop

End Sub

Answer 1

要每次正确复制新列，您需要一个在每次循环期间递增的变量，以便每次偏移一。当您使用

ThisCol + 1

时，您始终会获得相同的值，因为

ThisCol

未更新。

类似这样的：

Sub Copy()

    Dim MyFile As String
    Dim Filepath As String
    Dim q As Long

    Dim ThisCol As Integer
    Dim ThisRow As Long
    Dim CurS As Worksheet
    Dim CurRg As Range
    Dim InfCol As Integer

    
    Set CurS = ActiveSheet
    ThisRow = ActiveCell.Row
    ThisCol = ActiveCell.Column
    InfCol = 1


    Filepath = ReplacewithyouFilePath

    MyFile = Dir(Filepath)

    Do While Len(MyFile) > 0
        If MyFile = "Text to column.xlsm" Then
            Exit Sub
        End If

        'Let's keep a reference to the workbook
        Dim wb As Workbook
        Set wb = Workbooks.Open(Filepath & MyFile)
        
        'Let's keep a reference to the first sheet where the data is
        Dim ws As Worksheet
        Set ws = wb.Sheets(1)
        
        Dim LastRow As Long
        LastRow = ws.Range("G1").CurrentRegion.Rows.Count

        'We create a variable to increment at each column
        Dim Counter As Long
        
        'Let's make the copy operation using the Counter
        ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))

        'We increment the counter for the next file
        Counter = Counter + 1

        'We use wb to make sure we are referring to the right workbook
        wb.Save
        wb.Close
        MyFile = Dir
        
        'We free the variables for good measure
        Set wb = Nothing
        Set ws = Nothing
    Loop


End Sub

Answer 2

导入列

Sub ImportColumns()

    Const FOLDER_PATH As String = "C:\Test"
    Const FILE_EXTENSION_PATTERN As String = "*.xls*"
    Const SOURCE_WORKSHEET_ID As Variant = 1
    Const SOURCE_COLUMN As String = "G"
    Const SOURCE_FIRST_ROW As Long = 1
    Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    Const DESTINATION_COLUMN_OFFSET As Long = 1
    
    Dim pSep As String: pSep = Application.PathSeparator
    
    Dim FolderPath As String: FolderPath = FOLDER_PATH
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
    
    Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
    If Len(SourceFileName) = 0 Then
        MsgBox "No files found.", vbExclamation
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim sfCell As Range
    Dim slCell As Range
    
    Do While Len(SourceFileName) > 0
        If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
                <> 0 Then ' Why 'Exit Sub'? Is this the destination file?
            Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
            Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
            Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
            Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
            Set srg = sws.Range(sfCell, slCell)
            srg.Copy dfCell
            ' Or, if you only need values without formulas and formats,
            ' instead, use the more efficient:
            'dfCell.Resize(srg.Rows.Count).Value = srg.Value
            Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
            swb.Close SaveChanges:=False ' we are just reading, no need to save!
        'Else ' it's "Text to column.xlsm"; do nothing
        End If
        SourceFileName = Dir
    Loop

    Application.ScreenUpdating = True
    
    MsgBox "Columns imported.", vbInformation

End Sub