从文件夹将文件csv导入到单张纸中 [英] Importing Files csv from Folder into single sheet

问题描述

我正在使用以下代码将多个CSV文件放入一张工作表中.

I was using below code to get the multiple CSV files into single sheet.

代码可以正常工作，但是问题在于，它不应复制每个文件的标题，因为每个文件的标题都是相同的.

code is working fine but the issue is that, it should not copy the headers of each file, because each file header is same.

代码应复制第一个文件头，而不是所有文件.

Code should copy the first file header not all files.

我不希望第一列复制所有工作表名称的另一件事，我已尝试删除该文件，但代码不起作用.

One more thing that i do not want first column to copy all sheets name i have tried to remove that filed but code does not work.

我可以得到任何帮助吗?谢谢

Can i get any help. thanks

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

推荐答案

我做了两次尝试，第一次未经测试，并在手机上完成了

I did two attempts, first one untested, and did it on my phone:

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

计算机上的第二次尝试，我重构了代码处理的第一个文件大小写，跳过了剪贴板，并使用了正确的过程和变量名.

Second attempt from my computer, I refactored the code handled first file case, skipped the clipboard and use proper procedure and variable names.

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

这篇关于从文件夹将文件csv导入到单张纸中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！