堆栈内存溢出
  繁体   English   中英

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

[英]import all CSV files in folder

 原文  2018-06-23 16:50:56  4   3    excel/ vba/ excel-vba

问题描述

我使用此代码将所有CSV文件导入“电子邮件”文件夹中，但结果>>从第1行到第102行，他们将文件名放在四列中，然后转移了电子邮件。我如何仅导入没有文件名的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"

3 个解决方案

解决方案1
 0  2018-06-23 18:49:48

线 

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)

解决方案2
 0  2018-06-24 13:39:03

我懂了。 好吧，考虑一下。 

' 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来完成任务。 只是一个想法。

解决方案3
 -1  2018-06-23 17:08:44

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

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

在此处输入图片说明

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 需要在代码中保留文本格式以导入文件夹中的所有csv文件 VBA 从文件夹导入 all.csv 文件不起作用 如何选择文件夹中的所有.csv文件，然后通过VBA编码导入它们 VBA 将文件夹中的所有文件导入到 Access 如何打开文件夹中的所有文件（xls和csv格式文件） - VBA VBA在可变文件夹名称中查找所有CSV文件 使用Python将文件夹中的所有.xls文件附加到一个.csv文件中 如何在 VBA 中循环打开当前文件夹中的所有 csv 文件 检查文件夹中所有CSV文件的上次保存日期 将CSV文件导入Excel
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM