![](/img/trans.png)
[英]Combine multiple workbooks in a folder into one file, every workbook as a separate sheet, file name = sheet name - Excel VBA macro
[英]excel VBA, create a column with sheet or file name in cells while copying multiple CSV files to one workbook
我有 700 個 CSV 文件,每個文件有 7 列 1000 行,我需要將它們放在一個長列中。 示例代碼正在復制,但我不知道如何讓它在復制之前在每個單元格中創建一個列(與該文件中的其他列長度相同),其中包含工作表或文件名。 我真的只需要每個 CSV 文件中的 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
編碼
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.