Question

我想将多个工作簿中多个工作表中可用的数据复制到另一个工作簿中，但是表格和数据应该有一列工作簿名称（从中复制的位置）。例如具有7个不同名称的工作簿1名称（Raju-可以是任何名称）（工作簿中的工作表名称相同） Workbook2名称（pappu-可以是任何名称），具有7个不同名称的表格

在新的工作簿表格中复制..在结果工作簿中（第一张表应该包含第一张wkb 1和wkb 2中的所有数据以及第二张相同的内容）...并且在所有工作表工作簿名称中应该是从那里复制工作簿数据。

先谢谢你的帮助..

Option Explicit

Const ROW_FIRST As Integer = 2

Const BREAK_SHEET = 100000

-----------------------------------------------------------------------------------------------

Private Sub getFiles_Click()

'Creating Variables

Dim intResult As Integer, i As Double, strPath As String, objFSO As Object, intCountRows As Integer

Dim fileMap As New Scripting.dictionary

Dim fileName As Variant, filePath As String, sheet As Worksheet, openWb As Workbook

Dim sourceRange As String, noOfRecordsCopied As Double, noOfFilesScanned As Double, wbSheet As Worksheet

Set fileMap = New dictionary

'Initializing variables

i = ROW_FIRST

noOfRecordsCopied = 0

noOfFilesScanned = 0

'Get location of files to be copied

Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show

'Get all excel files in the selected location

If intResult <> 0 Then

    strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO, fileMap)

    Call GetAllFolders(strPath, objFSO, intCountRows, fileMap)

End If

'Add all the records to this excel

Dim sheetNo As Double

sheetNo = 1

For Each fileName In fileMap.Keys

    'Get the Funds required for Equity from T-2 File

    If (fileName Like "*.xl*") Then

        Set openWb = Workbooks.Open(fileMap(fileName))

        For Each sheet In openWb.Worksheets



            If i = ROW_FIRST Or i + sheet.UsedRange.Rows.Count > BREAK_SHEET Then

                Set wbSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

                wbSheet.Name = "Sheet" & sheetNo

                sheetNo = sheetNo + 1

                sheet.Range("1:1").Copy Destination:=wbSheet.Range("1:1")

                wbSheet.Range("A1").EntireColumn.Insert

                wbSheet.Range("A1").Value = "Name of File"

                i = ROW_FIRST

            End If

            sourceRange = "A2:" & ConvertToLetter(sheet.UsedRange.Columns.Count) & sheet.UsedRange.Rows.Count

            sheet.Range(sourceRange).Copy Destination:=wbSheet.Range("B" & i)

            wbSheet.Range("A" & i & ":A" & (i + sheet.UsedRange.Rows.Count - 2)).Value = fileName

            i = i + sheet.UsedRange.Rows.Count - 1

            noOfRecordsCopied = noOfRecordsCopied + sheet.UsedRange.Rows.Count - 1

            noOfFilesScanned = noOfFilesScanned + 1

        Next sheet

        openWb.Close (False)

    End If

Next fileName

'Enter statistics

Cells(4, 2) = noOfRecordsCopied

Cells(5, 2) = noOfFilesScanned

Sheets("Collator").Activate

End Sub



Private Function GetAllFiles(ByVal strPath As String, ByVal intRow As Integer, ByRef objFSO As Object, ByRef fileMap As Scripting.dictionary) As Integer

Dim objFolder As Object, objFile As Object, i As Integer

i = intRow - ROW_FIRST + 1

Set objFolder = objFSO.GetFolder(strPath)

For Each objFile In objFolder.Files

    fileMap(objFile.Name) = objFile.Path

    i = i + 1

Next objFile

GetAllFiles = i + ROW_FIRST - 1

End Function



-----------------------------------------------------------------------------------------------------------------------------------------



Private Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object, ByRef intRow As Integer, ByRef fileMap As Scripting.dictionary)

Dim objFolder As Object, objSubFolder As Object

Set objFolder = objFSO.GetFolder(strFolder)

For Each objSubFolder In objFolder.subFolders

    intRow = GetAllFiles(objSubFolder.Path, intRow, objFSO, fileMap)

    Call GetAllFolders(objSubFolder.Path, objFSO, intRow, fileMap)

Next objSubFolder

End Sub

Answer 1

尝试以下脚本。

Sub Basic_Example_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

另外，请从下面的URL中查看AddIn。

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

将多个工作簿中的数据复制到单个工作簿明智

1 个答案: