excel - 将文件夹中的文件 csv 导入单个工作表
问题描述
我正在使用下面的代码将多个 CSV 文件放入单张纸中。
代码工作正常,但问题是,它不应该复制每个文件的标题,因为每个文件标题都是相同的。
代码应该复制第一个文件头而不是所有文件。
还有一件事我不希望第一列复制所有工作表名称我试图删除该文件但代码不起作用。
我能得到任何帮助吗?谢谢
Sub CSV()
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub
解决方案
编辑:我做了两次尝试,第一次未经测试,并在我的手机上做了:
Sub CSV()
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Dim counter as Long
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Dim sourceRange as Range
Set sourceRange = xWb.Worksheets(1).UsedRange
If counter = 0 then
sourceRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
else
sourceRange.Offset(1, 0).Resize(sourceRange.Rows.Count - 1, sourceRange.Columns.Count).Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
xWb.Close False
xFile = Dir
counter = counter + 1
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub
从我的计算机进行第二次尝试,我重构了处理第一个文件大小写的代码,跳过了剪贴板并使用了正确的过程和变量名称。
Public Sub ImportAndAppendCSVFromFolder()
' Set basic error handling
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
' Prepare and display file dialog to user
Dim customFileDialog As FileDialog
Set customFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
customFileDialog.AllowMultiSelect = False
customFileDialog.Title = "Select a folder"
' Get folder path from file dialog
If customFileDialog.Show = -1 Then
Dim folderPath As String
folderPath = customFileDialog.SelectedItems(1)
End If
' Exit if nothing was selected
If folderPath = vbNullString Then Exit Sub
' Set reference to active sheet (could be replaced to a specific sheet name with this: ThisWorkbook.Worksheets("SheetName") )
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.ActiveSheet
' Get files in directory ending with specific extension
Dim sourceFile As String
sourceFile = Dir(folderPath & "\" & "*.csv")
' Loop through files
Do While sourceFile <> ""
' Open file
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks.Open(folderPath & "\" & sourceFile)
' Set reference to sheet in file (as it's a csv file, it only has one worksheet)
Dim sourceSheet As Worksheet
Set sourceSheet = sourceWorkbook.Worksheets(1)
' Depending if it's the first file, include headers or not
Dim counter As Long
If counter = 0 Then
' Set reference to used range in source file
Dim sourceRange As Range
Set sourceRange = sourceSheet.UsedRange
' Calc offset if it's first file
Dim rowOffset As Long
rowOffset = 0
Else
' Don't include headers in range
Set sourceRange = sourceSheet.UsedRange.Offset(1, 0).Resize(sourceSheet.UsedRange.Rows.Count - 1, sourceSheet.UsedRange.Columns.Count)
' Calc offset if it's not first file
rowOffset = 1
End If
' Perform copy (as this comes from a csv file, we can skip the clipboard
targetSheet.Range("A" & targetSheet.Rows.Count).End(xlUp).Resize(sourceRange.Rows.Count, sourceRange.Columns.Count).Offset(rowOffset).Value2 = sourceRange.Value2
' Close csv file
sourceWorkbook.Close False
' Get reference to next file
sourceFile = Dir
counter = counter + 1
Loop
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
推荐阅读
- ios - 带有 UIAppearance 的自定义类上的圆形按钮
- html - h,b 和 sup 标签什么都不做 + 更多问题
- php - 拉拉维尔 5.6。如何在 WHERE 条件下使用变量?
- pandas - 基于行数的子集
- hyperledger-fabric - 在运行我的第一个网络时,对等链码 instatiate 挂起
- android - 运行地图活动时应用程序崩溃
- apache-beam - Apache Beam - 用于运动流的滑动窗口
- html - Apache 2.4 的 HTTP 授权条件规则
- javascript - TypeError:x 不是 Node.js 中的函数
- reactjs - React JS - 使用本地 JSON 文件时如何传递变量(参数)?