将数据从 .csv 文件传输到工作簿

Question

我正在尝试在 Excel 中编写一个宏：

1. 遍历数百个 .csv 文件。

2. 获取他们的名字并将他们放在目标工作簿的第一行。

3. 从每个.csv 文件中复制columns E & R 并将它们粘贴到目标工作簿中相应名称的下方。

示例： 在目标工作簿中，我应该得到单元格 A1 中的 title_1（csv_1），然后将来自 csv_1 的 columns E & R 的数据粘贴到 cells A2 & B2 中。 C 列为空。然后cell D1中的title_2（csv_2），各自的columns E & R粘贴在D2 & E2中。 F列为空，依此类推...

I would like the data to be organize like this

尝试：

Sub LoopExcels ()
    
    Dim directory As String
    Dim fileName As String
    Dim i As Integer
    Dim j As Integer
    Dim wb As Workbook
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim ColOutputTarget As Long
    
    ColOutputTarget = 1
    
    Set wsTarget = Sheets("Sheet1")
    
    Application.ScreenUpdating = FALSE
    Application.DisplayAlerts = FALSE
    
    directory = "C:\data"
    fileName = Dir(directory & "*.csv")
    
    Do Until fileName = ""
        
        Set wbSource = Workbooks.Open(directory & fileName)
        Set wsSource = wbSource.Worksheets(1)
        
        j = j + 1
        i = 1
        Cells(i, 1) = fileName
        
        Workbooks.Open (directory & fileName)
        
        For Each sheet In Workbooks(fileName).Worksheets        'my excels contain only one sheet but didn't know how to get rid of the "For each sheet"
            wsTarget.Cells(i, j).Value = sheet.Name
            j = j + 2
            
        Next sheet
        
        With wsTarget
            .Range("A" & ColOutputTarget).Value = wsSource.Range("E1:E100").Value        'Need to copy all data in columns it can be 10 cells and it doesn't exceed 100 cells
            .Range("B" & ColOutputTarget).Value = wsSource.Range("R1:R100").Value
            
            ColOutputTarget = ColOutputTarget + 1
            
        End With
        
        wbSource.Close SaveChanges:=False
        
        fileName = Dir()
        
    Loop
    
    Application.CutCopyMode = FALSE
    
End Sub

我一直在寻找没有运气的解决方案。

• 我找到了一种循环文件的方法

• 我设法部分获取了每个文件的名称（我发现了一个代码，它可以遍历 Excel 文件中的所有工作表。我的文件只包含一个工作表，所以也许可以简化） 由于某种原因，它不会复制全名。一些文件的名称很长，+50 个字符。

• 我在复制/粘贴列时遇到问题。每列包含 10 到 100 个单元格的数据。 下面的代码遍历文件，但将数据粘贴到同一列中。我最终只从它打开的最后一个 excel 文件中获取数据，该文件粘贴在前 2 列中。 每次处理完每个 csv 文件时，我都找不到让它转移到下一列的方法。

Answer 1

为了工作：

• 您需要将 Excel 文件（包含宏）放在 .CSV 文件的文件夹中。

• 在主 Excel 文件中创建 2 张名为“文件名”和“目标表”的工作表。如果需要，您可以在代码中更改它。

• 如果您使用的是 Windows，只需插入包含 .csv 文件的文件夹的路径。

• 如果您使用的是 mac，请插入包含 .csv 文件的文件夹的路径，并将宏中的所有 "\" 更改为 "/"。

  Sub Awesome()
  
  getNames
  positionTitles
  transferData
  
  End Sub
  
  Sub getNames()
  
    Dim sFilePath As String
    Dim sFileName As String
    Dim counter As Long
  
    counter = 1
  
    'Specify folder Path for the .csv files
    sFilePath = "c:\"
  
    'Check for back slash
    If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If
  
    sFileName = Dir(sFilePath & "*.csv")
  
    Do While Len(sFileName) > 0
        If Right(sFileName, 3) = "csv" Then
            'Display file name in immediate window
             Sheets("file names").Cells(counter, 1) = sFileName
            counter = counter + 1
        End If
        'Set the fileName to the next available file
        sFileName = Dir
    Loop
  
  End Sub
  
  
  Sub positionTitles()
  
  Dim counter As Long
  Dim used_range As Range
  Dim col As Long
  
  col = 1
  
  Set used_range = Sheets("file names").UsedRange
  
  For counter = 1 To used_range.Rows.Count
  
  Sheets("target sheet").Cells(1, col) = Sheets("file names").Cells(counter, 1)
  
  col = col + 4
  
  Next counter
  
  End Sub
  
  
  Sub transferData()
  
  'turn off unnecessary applications
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  
  Dim file_name As String
  Dim counter As Long
  Dim used_range As Range
  Dim main_wb As Workbook
  Dim col As Long
  Dim key As Boolean
  Dim last_row As Long
  Dim second_key As Boolean
  
  col = 1
  
  Set main_wb = ThisWorkbook
  Set used_range = Sheets("file names").UsedRange
  
  
  For counter = 1 To used_range.Rows.Count
  
    file_name = main_wb.Sheets("file names").Cells(counter, 1)
  
    Workbooks.Open ActiveWorkbook.Path & "\" & file_name, Local:=True
  
    'transfer data to target_sheet
    For col = col To 1000
  
        If key = False Then
            last_row = ActiveWorkbook.ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
            ActiveWorkbook.ActiveSheet.Range("E1:E" & last_row).Copy
            main_wb.Sheets("target sheet").Cells(2, col).PasteSpecial
            key = True
        ElseIf second_key = False Then
         last_row = ActiveWorkbook.ActiveSheet.Range("R" & Rows.Count).End(xlUp).Row
        ActiveWorkbook.ActiveSheet.Range("R1:R" & last_row).Copy
        main_wb.Sheets("target sheet").Cells(2, col).PasteSpecial
        second_key = True
     Else
        last_row = ActiveWorkbook.ActiveSheet.Range("K" & Rows.Count).End(xlUp).Row
        ActiveWorkbook.ActiveSheet.Range("K1:K" & last_row).Copy
        main_wb.Sheets("target sheet").Cells(2, col).PasteSpecial
        col = col + 2
        Exit For
    End If
  
    Next col
  
    key = False
    second_key = False
    Workbooks(file_name).Close savechanges:=False
  
  Next counter
  
  'turn on applications
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.DisplayAlerts = True
  
  End Sub