解析文件夹中的所有工作簿并创建主工作表

时间:2014-07-12 14:30:29

标签: excel-vba vba excel

我有许多excel文件,每个文件只有一个工作表,位于包含5个来源数据的文件夹中。源位于列L.我想读取所有文件的每一行并创建5个主工作表。我认为源的数量不应仅限于5个源,宏应该只读取所有文件中的所有行,并根据位于单元格L中的值将行复制到主工作表.Start_Row为3用于读写。我认为我有工作代码来阅读每个文件和每个工作表,但是在读取和写入行时遇到问题

Sub ParseByDevice()

Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim wbThis As Workbook
Dim ws As Worksheet
Dim Pws As Worksheet 'Parsed Worksheet based on Column L (i, 12)
Dim a As Range
Dim b As Range
Dim rw As Range
Dim cl As Range 
Dim MyBook As Workbook
Dim newBook As Workbook
Dim FileNm As String

Application.EnableEvents = False
Application.ScreenUpdating = False

Path = "C:\xml\vac" 'Change as needed
FileName = Dir(Path & "\livevalues*.xls", vbNormal)

'
'ALL FILES IN FOLDER LOOP
'
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)

'
'ALL EACH WORKSHEET IN WORKBOOK LOOP
'
'next worksheet in file;
'only expect one worksheet but maybe more in the future
'
For Each ws In Wkb.Worksheets

    '
    ' FOR EACH ROW IN WORKSHEET LOOP
    '
        rw = 3  'first row after header
        For Each rw In ws

        MsgBox Wkb.Sheets(ws).row(rw, 12).Value 'this is temporary, just a visual check that things are going well
        cl = Wkb.Sheets(ws).row(rw, 12).Value
        Wkb.Sheets(ws).row(rw, 12).Copy Pws.Sheets(cl)

    Next rw 'next row in worksheet

Next ws 'next worksheet in file;

    Wkb.Close False
    FileName = Dir()

Loop 'Do next file in folder

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

1 个答案:

答案 0 :(得分:0)

一种方法:

Application.EnableEvents = False
Application.ScreenUpdating = False

Path = "C:\xml\vac" 'Change as needed
FileName = Dir(Path & "\livevalues*.xls", vbNormal)

Set MyBook = ThisWorkbook

Do Until FileName = ""

    Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)

    For Each ws In Wkb.Worksheets

        rw = 3  'first row after header
        Do
            tmp = ws.Cells(rw, 12).Value
            If Len(tmp) = 0 Then Exit Do

            Set Pws = Nothing

            On Error Resume Next
            Set Pws = ThisWorkbook.Sheets(tmp)
            On Error GoTo 0

            If Pws Is Nothing Then
                Set Pws = MyBook.Worksheets.Add( _
                   after:=MyBook.Sheets(MyBook.Sheets.Count))
                Pws.Name = tmp
            End If

            ws.Rows(rw).Copy Pws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

            rw = rw + 1
        Loop

    Next ws 'next worksheet in file;

    Wkb.Close False
    FileName = Dir()

Loop 'Do next file in folder

Application.EnableEvents = True
Application.ScreenUpdating = True