导入TXT文件并为每个分组表创建新的工作表

Question

我已将几个CSV文件组合成一个大文本文件。我需要将这个文本文件导入到Excel中，并且每次在文本文件中有2个空白行时创建一个新的工作表。

有没有一个宏可以做到这一点？

将example.txt文件：

"Date","Country","Price", 
"12/01/12","US","$4.99", 
"12/02/12","US","$4.99", 


"Date","Country","Price", 
"12/01/13","US","$4.99", 
"12/02/13","US","$4.99", 


"Date","Country","Price", 
"12/01/14","US","$4.99", 
"12/02/14","US","$4.99", 

Answer 1

好吧，没有人帮助过。所以我刚刚删除了大文本文件并创建了一个宏来导入所有原始的csv。

Sub LoadAllFilesPerSheet() 
Dim idx As Integer 
Dim fpath As String 
Dim fname As String 
idx = 0 
fpath = "c:\foobar\" 
fname = Dir(fpath & "*.csv") 
While (Len(fname) > 0) 
    idx = idx + 1 
    Sheets("Sheet" & idx).Select 
    Sheets.Add After:=ActiveSheet 
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" _ 
     & fpath & fname, Destination:=Range("A1")) 
     .Name = "a" & idx 
     .FieldNames = True 
     .RowNumbers = False 
     .FillAdjacentFormulas = False 
     .PreserveFormatting = True 
     .RefreshOnFileOpen = False 
     .RefreshStyle = xlInsertDeleteCells 
     .SavePassword = False 
     .SaveData = True 
     .AdjustColumnWidth = True 
     .RefreshPeriod = 0 
     .TextFilePromptOnRefresh = False 
     .TextFilePlatform = 437 
     .TextFileStartRow = 1 
     .TextFileParseType = xlDelimited 
     .TextFileTextQualifier = xlTextQualifierDoubleQuote 
     .TextFileConsecutiveDelimiter = False 
     .TextFileTabDelimiter = False 
     .TextFileSemicolonDelimiter = False 
     .TextFileCommaDelimiter = True 
     .TextFileSpaceDelimiter = False 
     .TextFileOtherDelimiter = "" 
     .TextFileColumnDataTypes = Array(1, 1, 1) 
     .TextFileTrailingMinusNumbers = True 
     .Refresh BackgroundQuery:=False 
     fname = Dir 
    End With 
Wend 

末次

Answer 2

我在几个星期前，准备类似的东西，我进入了一些调整，这样我可以跟你的榜样工作。但请记住，SO不是请求代码的网站。

下面的内容应该起作用。但在此之前，你应该将CSV文件导入到工作表，以便它想的是：

Sub CopyData() 

Dim cell As Range 
Dim SourceWorksheet As Worksheet 
Set SourceWorksheet = ActiveSheet 

Dim TempFirstRowNumber As Long: TempFirstRowNumber = 1 

For Each cell In Intersect(SourceWorksheet.Range("A:A"), SourceWorksheet.UsedRange) 
    If cell.Value = "" And cell.Offset(1, 0).Value = "" Then 
     Sheets.Add after:=ActiveSheet 
     SourceWorksheet.Range("A" & TempFirstRowNumber & ":C" & (cell.Row - 1)).Copy ActiveSheet.Range("A1") 

     TempFirstRowNumber = cell.Offset(2, 0).Row 
    End If 
Next cell 

Sheets.Add after:=ActiveSheet 
SourceWorksheet.Range("A" & TempFirstRowNumber & ":C" & (SourceWorksheet.UsedRange.Rows.Count)).Copy ActiveSheet.Range("A1") 

End Sub 

Answer 3

下面是一个完整的模块代码页。将其粘贴到新的空白工作簿中的新模块代码表时，请勿在页面顶部留下两行Option Explicit行。

Option Explicit 

Sub split_Date_Tables() 
    Dim rowCurr As Long, tbl As Long 
    Dim tlc As String, pth As String, fn As String, pthfn As String 
    Dim fnd As Range 

    On Error GoTo bm_Safe_Exit 
    'set up the application environment for speed (see Sub appTGGL below) 
    appTGGL bTGGL:=False 

    pth = Environ("TEMP") 
    fn = "example.txt" 
    pthfn = pth & Chr(92) & fn 
    tlc = "Date" 'header text in the Top-Left-Corner of each table 

    'get rid of everything but the first blank worksheet 
    Do While Sheets.Count > 1 
     Sheets(2).Delete 
    Loop 

    'Importing a TXT is a lot of code that largely means nothing but has to set paramteters. 
    'Put it in its own sub 
    Call importTXT(Worksheets(1), pthfn, "txtSource") 

    With Worksheets(1) 
     With .Columns(1) 
      Set fnd = .Find(What:=tlc, LookIn:=xlValues, _ 
          after:=.Cells(Rows.Count), _ 
          LookAt:=xlWhole, SearchOrder:=xlByColumns, _ 
          SearchDirection:=xlNext, MatchCase:=False) 
      Do While Not fnd Is Nothing 
       rowCurr = fnd.Row 
       tbl = tbl + 1 
       On Error GoTo bm_New_Worksheet 
       With Worksheets(Format(tbl, "\C\S\V\-\000")) 
        On Error GoTo bm_Safe_Exit 
        .Cells.Clear 
        fnd.CurrentRegion.Copy _ 
         Destination:=.Cells(1, 1) 
       End With 
       Set fnd = .FindNext(after:=fnd) 
       If rowCurr > fnd.Row Then Exit Do 
      Loop 
      On Error GoTo bm_Safe_Exit 
     End With 
     .Activate 
    End With 

    GoTo bm_Safe_Exit 

bm_New_Worksheet: 
    If Err.Number = 9 Then 
     With Worksheets.Add(after:=Sheets(Sheets.Count)) 
      .Name = Format(tbl, "\C\S\V\-000") 
     End With 
     Resume 
    End If 

bm_Safe_Exit: 
    appTGGL 

End Sub 

Sub importTXT(ws As Worksheet, fn As String, nam As String) 
    With ws 
     'nuke all existing data on this worksheet in favour of hte new data 
     .Cells.Clear 
     'bring in the new data 
     With .QueryTables.Add(Connection:="TEXT;" & fn, _ 
      Destination:=.Range("$A$1")) 
      .Name = nam 
      .FieldNames = True 
      .RowNumbers = False 
      .FillAdjacentFormulas = False 
      .PreserveFormatting = True 
      .RefreshOnFileOpen = False 
      .RefreshStyle = xlOverwriteCells 
      .SavePassword = False 
      .SaveData = True 
      .AdjustColumnWidth = True 
      .RefreshPeriod = 0 
      .TextFilePromptOnRefresh = False 
      .TextFilePlatform = 437 
      .TextFileStartRow = 1 
      .TextFileParseType = xlDelimited 
      .TextFileTextQualifier = xlTextQualifierDoubleQuote 
      .TextFileConsecutiveDelimiter = False 
      .TextFileTabDelimiter = False 
      .TextFileSemicolonDelimiter = False 
      .TextFileCommaDelimiter = True 
      .TextFileSpaceDelimiter = False 
      .TextFileColumnDataTypes = Array(3, 2, 1, 9) 
      .Refresh BackgroundQuery:=False 
     End With 
     'we do not need to save this Data Connection. Get rid of it 
     .Parent.Connections(.Parent.Connections.Count).Delete 
    End With 
End Sub 

Sub appTGGL(Optional bTGGL As Boolean = True) 
    Application.ScreenUpdating = bTGGL 
    Application.EnableEvents = bTGGL 
    Application.DisplayAlerts = bTGGL 
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual) 
End Sub 

IMO，这是一个非常好的框架，您可以建立和自定义您自己的目的。为了首次使用它，你将不得不修改代码开头附近的字符串赋值。具有不同表格布局的CSV可能必须修改实际的导入子过程。

两点：

• 你的样本CSV显示尾随逗号。这会使空的领域离开右边。我从导入中丢弃了这些字段。例如xlSkipColumn = 9
• 您的日期不明确。我猜对了一个MDY格式。使用在TextFileColumnDataTypes property找到的值来调整导入的字段类型。