利用Excel VBA，在将多个CSV文件复制到一个工作簿时，在单元格中创建包含工作表或文件名的列。

Question

利用Excel VBA，在将多个CSV文件复制到一个工作簿时，在单元格中创建包含工作表或文件名的列。

3

我有700个CSV文件，每个文件有7列1000行，我需要把它们合并成一个长列。示例代码可以进行复制，但我不知道如何在复制之前创建一列（与该文件中的其他列长度相同），并将每个单元格中的工作表或文件名添加到该列中。如果可能的话，我只需要从每个CSV文件中获取A列（日期）、创建的列（工作表名称）和F列（值），顺序为A、创建的列和F。

    Sub ImportData()
Dim lastrow As Long
Dim clastrow As Long
Dim filePath As String
Dim fileName As String
Dim count As Long
Dim importRange As Range
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim cws As Excel.Worksheet
count = 0
Set cws = ThisWorkbook.Sheets(2)
filePath = "C:\Users\user\Desktop\CSV files\"
fileName = Dir(filePath & "*.csv")
Do While fileName <> ""
    count = count + 1
    Set wb = Excel.Workbooks.Open(filePath & fileName)
    Set ws = wb.Worksheets(1)
    lastrow = ws.Cells(Rows.count, "a").End(xlUp).Row
    clastrow = cws.Cells(Rows.count, "a").End(xlUp).Row + 1
    Set importRange = ws.Range("a2:f" & lastrow)           'skips header row
'    cws.Cells(clastrow, 1).End(xlUp).Offset(1, 0).Resize(importRange.Rows.count, importRange.Columns.count) = importRange.Value
    importRange.Copy
    cws.Cells(clastrow, "a").PasteSpecial xlPasteValues
    wb.Application.CutCopyMode = False
    wb.Close
    fileName = Dir
Loop
End Sub

- Daniel

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- VBasic2008 · Accepted Answer

通过赋值复制值

未经测试。

代码

Option Explicit
    
Sub importData()
    
    ' Define constants.
    Const FilePath As String = "C:\Users\user\Desktop\CSV files\"
    
    ' Define Destination First Cell.
    Dim drg As Range
    With ThisWorkbook.Sheets(2)
        Set drg = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
    End With
    
    ' Write the first file name to a variable.
    Dim FileName As String: FileName = Dir(FilePath & "*.csv")
    
    ' Declare additional variables.
    Dim srg As Range ' Source Range
    Dim sLastRow As Long ' Source Last Row
    Dim srCount As Long ' Source Rows Count
    Dim fCount As Long ' Files Count
    
    ' Copy values by assignment.
    Application.ScreenUpdating = False
    Do While FileName <> ""
        With Workbooks.Open(FilePath & FileName).Worksheets(1)
            sLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            If sLastRow >= 2 Then
                fCount = fCount + 1
                Set srg = .Range("A2:F" & sLastRow)
                srCount = srg.Rows.Count
                Set drg = drg.Resize(srCount)
                drg.Value = srg.Columns(1).Value
                drg.Offset(, 1).Value = .Name
                drg.Offset(, 2).Value = srg.Columns(6).Value
                Set drg = drg.Cells(1).Offset(srCount)
            End If
            .Parent.Close SaveChanges:=False
        End With
        FileName = Dir
    Loop
    'drg.Worksheet.Parent.Save
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Files processed: " & fCount, vbInformation, "Success"

End Sub