Question

我有5个文件夹：

version1
version2
version3
version4
version5

每个文件夹都有四个excel文件：

gt
ga
ra
fe
ca

我想从每个excel文件中将列名为CC的特定列数据提取到工作簿中的不同工作表中。使用VBA将数据从所有文件夹提取到单个文件中。请帮忙吗？谢谢！

Answer 1

此代码应该可以满足您的需求。

请注意，此代码将查看每个工作簿的第一行以查找值＆＃34; CC＆＃34;。另请注意，这假设数据位于每个工作簿的第一张表中。

Sub CopyColumns()

Dim TargetWb, SourceWb As Workbook
Dim myPath, myFile, myExtension, LastRowSource, LastRowTarget As String
Dim SourceColNo, TargetColNo, RowNo, SheetNo As Long
Dim Folder, FolderArray As Variant
Dim CopyHeaders As Boolean
Set TargetWb = ActiveWorkbook
Application.ScreenUpdating = False

    '******************************************************************************************
    ' ************************* USER VARIABLES - PLEASE CHANGE ********************************
    '******************************************************************************************

        'Set Column Index to which data will be entered on this workbook

        TargetColNo = 1

        'Set the sheet number you wish to start inserting data from

        SheetNo = 1

        'Copy header row

        CopyHeader = True

        'Set Target Folder Path which contains folders "Version1" etc

        myPath = "C:\New\"

        'Target File Extension (must include wildcard "*")

        myExtension = "*.xlsx"

        'Folder names to search, should you wish to change, add or remove any

        FolderArray = Array("version1", "version2", "version3", "version4", "version5")

    '******************************************************************************************
    '******************************************************************************************
    '******************************************************************************************

    'Convert Col No to Letter

    Dim TgtColLetter
    TgtColLetter = Split(Cells(1, TargetColNo).Address(True, False), "$")

        'Loop through folders

        For Each Folder In FolderArray

        'Target Path with Ending Extention

        myFile = Dir(myPath & Folder & "\" & myExtension)

        'Loop through each Excel file in folder
            Do While myFile <> ""


                'Set variable equal to opened workbook
                Set SourceWb = Workbooks.Open(Filename:=myPath & Folder & "\" & myFile)

                'Find Column named 'CC'

                SourceColNo = WorksheetFunction.Match("CC", SourceWb.Sheets(1).Range("A1:H1"), 0)
                Dim SrcColLetter
                SrcColLetter = Split(Cells(1, SourceColNo).Address(True, False), "$")

                'Get Last Row of Source Workbook
                LastRowSource = SourceWb.Sheets(1).Cells(Rows.Count, SourceColNo).End(xlUp).Row

                'Get Last Row of Target Workbook and add new sheets as required
                On Error Resume Next
                LastRowTarget = TargetWb.Sheets(SheetNo).Cells(Rows.Count, TargetColNo).End(xlUp).Row
                If Err.Number <> 0 Then
                TargetWb.Activate
                TargetWb.Sheets.Add After:=TargetWb.Worksheets(Worksheets.Count)
                End If
                On Error GoTo 0


                If CopyHeader = False Then
                RowNo = 2
                Else
                RowNo = 1
                End If

                'Copy from Source to Target
                SourceWb.Sheets(1).Range(SrcColLetter(0) & RowNo & ":" & SrcColLetter(0) & LastRowSource).Copy _
                Destination:=TargetWb.Sheets(SheetNo).Range(TgtColLetter(0) & LastRowTarget)

                'Close Workbook
                SourceWb.Close SaveChanges:=False

                'Get next file name
                myFile = Dir

                'Move to next sheet on TargetWb
                SheetNo = SheetNo + 1
            Loop

        Next Folder

    Application.ScreenUpdating = True

End Sub

获取列名称为＃34; CC＆＃34;的特定列数据来自不同文件夹的不同excel表

1 个答案: