Question

我使用此代码将所有CSV文件导入“电子邮件”文件夹中，但结果>>从第1行到第102行，他们将文件名分为四列，然后转移了emails。我如何不导入csv文件内容而又文件名（文件夹包含4个CSV文件“ Email1，Email2，Email3，Email4”）

Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214 // Vertically
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

xStrPath = ("D:\Excel\Learning Excel VBA\Outlook VBA\Emails")

If xStrPath = "" Then Exit Sub

Set xSht = ThisWorkbook.ActiveSheet

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

结果

Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  Email1
Email4  Email3  Email2  "From:  Montaser Abu Roumi <msroumi@gmail.com>"
Email4  Email3  Email2  "Sent:  Sunday"
Email4  Email3  Email2  "To:    msroumi@hotmail.com"
Email4  Email3  Email2  "Subject:   5896321574"
Email4  Email3  Email2  
Email4  Email3  Email2  GOPS / hold CC 7th circle 
Email4  Email3  "From:  Montaser Abu Roumi <msroumi@gmail.com>" 
Email4  Email3  "Sent:  Sunday"  June 17
Email4  Email3  "To:    msroumi@hotmail.com"    
Email4  Email3  "Subject:   1505264896" 
Email4  Email3      
Email4  Email3  GTW / Aramex    
Email4  "From:  Montaser Abu Roumi <msroumi@gmail.com>"     
Email4  "Sent:  Sunday"  June 17     2018 5:20 PM
Email4  "To:    msroumi@hotmail.com"        
Email4  "Subject:   5879658396"     
Email4          
Email4  GTW / Al Dar for clearance      
"From:  Montaser Abu Roumi <msroumi@gmail.com>"         
"Sent:  Sunday"  June 17     2018 5:19 PM   
"To:    msroumi@hotmail.com"            
"Subject:   1801504685"

Answer 1

行

Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name

用工作表名称填充所选范围，对于csv文件，该名称是文件名。因此，为什么最后要用一列填充文件名！

您是否尝试过删除该行来运行代码？

实际上，请尝试更改此内容...

Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)

收件人

xSht.Columns(1).Insert xlShiftToRight
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)

Answer 2

我明白了。好的，考虑一下。

' Merge data from multiple sheets into separate sheets
Sub R_AnalysisMerger2()
    Dim WSA As Worksheet
    Dim bookList As Workbook
    Dim SelectedFiles As Variant
    Dim NFile As Long
    Dim FileName As String
    Dim Ws As Worksheet, vDB As Variant, rngT As Range
    Dim vFn, myFn As String

    Application.ScreenUpdating = False

    SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True)
    If IsEmpty(SelectedFiles) Then Exit Sub

    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        FileName = SelectedFiles(NFile)
        vFn = Split(FileName, "\")
        myFn = vFn(UBound(vFn))
        myFn = Replace(myFn, ".csv", "")
        Set bookList = Workbooks.Open(FileName, Format:=2)
        Set WSA = bookList.Sheets(1)
        vDB = WSA.UsedRange
        bookList.Close (0)
        Set Ws = Sheets.Add(after:=Sheets(Sheets.Count))
        ActiveSheet.Name = myFn
        Ws.Range("a1").Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
    Next
    Application.ScreenUpdating = True

End Sub

' Merge data from multime files into one sheet.
Sub R_AnalysisMerger()
    Dim WSA As Worksheet
    Dim bookList As Workbook
    Dim SelectedFiles() As Variant
    Dim NFile As Long
    Dim FileName As String
    Dim Ws As Worksheet, vDB As Variant, rngT As Range

    Application.ScreenUpdating = False


    Set Ws = ThisWorkbook.Sheets(1)
    Ws.UsedRange.Clear
    'change folder path of excel files here
    SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True)


    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        FileName = SelectedFiles(NFile)
        Set bookList = Workbooks.Open(FileName, Format:=2)
        Set WSA = bookList.Sheets(1)
        With WSA
            vDB = .UsedRange
            Set rngT = Ws.Range("a" & Rows.Count).End(xlUp)(2)
            If rngT.Row = 2 Then Set rngT = Ws.Range("a1")
            rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB

            bookList.Close (0)
        End With
    Next
    Application.ScreenUpdating = True
    Ws.Range("A1").Select

End Sub

您可能要考虑使用Python或R来完成任务。只是一个想法。

Answer 3

下面链接中的AddIn可以完全满足您的要求。

https://www.rondebruin.nl/win/addins/rdbmerge.htm

导入文件夹中的所有CSV文件

3 个答案: