Question

如果这是一个愚蠢的问题，我真的很抱歉，但我正在使用的宏在我合并它们时会继续附加新的工作簿数据。

理想情况下，我希望新工作簿在单元格AA1旁边，而不是直接附加在图片中。对不起，我无法提供更多帮助。我一直在努力让它开始让其他工作簿不能附加，而是从其他工作簿中写出它实际上的位置。到目前为止没有运气。

我相信我会在几个小时左右到达那里，但如果你愿意提供帮助，请再次感谢。

Option Explicit
Public Sub CombineManyWorkbooksIntoOneWorksheet()

    Dim strDirContainingFiles As String, strFile As String, _
        strFilePath As String
    Dim wbkDst As Workbook, wbkSrc As Workbook
    Dim wksDst As Worksheet, wksSrc As Worksheet
    Dim lngIdx As Long, lngSrcLastRow As Long, _
        lngSrcLastCol As Long, lngDstLastRow As Long, _
        lngDstLastCol As Long, lngDstFirstFileRow As Long
    Dim rngSrc As Range, rngDst As Range, rngFile As Range
    Dim colFileNames As Collection
    Set colFileNames = New Collection

    'Set references up-front
    strDirContainingFiles = "C:\Users\Guide\Projects\" '<~ your folder
    Set wbkDst = Workbooks.Add '<~ Dst is short for destination
    Set wksDst = wbkDst.ActiveSheet

    'Store all of the file names in a collection
    strFile = Dir(strDirContainingFiles & "\*.xlsm")
    Do While Len(strFile) > 0
        colFileNames.Add Item:=strFile
        strFile = Dir
    Loop

    ''CHECKPOINT: make sure colFileNames has the file names
    'Dim varDebug As Variant
    'For Each varDebug In colFileNames
    '    Debug.Print varDebug
    'Next varDebug

    'Now we can start looping through the "source" files
    'and copy their data to our destination sheet
    For lngIdx = 1 To colFileNames.Count

        'Assign the file path
        strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)

        'Open the workbook and store a reference to the data sheet
        Set wbkSrc = Workbooks.Open(strFilePath)
        Set wksSrc = wbkSrc.Worksheets("Sheet1")

        'Identify the last row and last column, then
        'use that info to identify the full data range
        lngSrcLastRow = LastOccupiedRowNum(wksSrc)
        lngSrcLastCol = LastOccupiedColNum(wksSrc)
        With wksSrc
            Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, _
                                                     lngSrcLastCol))
        End With

        ''CHECKPOINT: make sure we have the full source data range
        'wksSrc.Range("A1").Select
        'rngSrc.Select

        'If this is the first (1st) loop, we want to keep
        'the header row from the source data, but if not then
        'we want to remove it
        If lngIdx <> 1 Then
            Set rngSrc = rngSrc.Offset(1, 0).Resize(rngSrc.Rows.Count - 1)
        End If

        ''CHECKPOINT: make sure that we remove the header row
        ''from the source range on every loop that is not
        ''the first one
        'wksSrc.Range("A1").Select
        'rngSrc.Select

        'Copy the source data to the destination sheet, aiming
        'for cell A1 on the first loop then one past the
        'last-occupied row in column A on each following loop
        If lngIdx = 1 Then
            lngDstLastRow = 1
            Set rngDst = wksDst.Cells(1, 1)
        Else
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
        End If
        rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste

        'Almost done! We want to add the source file info
        'for each of the data blocks to our destination

        'On the first loop, we need to add a "Source Filename" column
        If lngIdx = 1 Then
            lngDstLastCol = LastOccupiedColNum(wksDst)
            wksDst.Cells(1, lngDstLastCol + 1) = "Source Filename"
        End If

        'Identify the range that we need to write the source file
        'info to, then write the info
        With wksDst

            'The first row we need to write the file info to
            'is the same row where we did our initial paste to
            'the destination file
            lngDstFirstFileRow = lngDstLastRow + 1

            'Then, we need to find the NEW last row on the destination
            'sheet, which will be further down (since we pasted more
            'data in)
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            lngDstLastCol = LastOccupiedColNum(wksDst)

            'With the info from above, we can create the range
            Set rngFile = .Range(.Cells(lngDstFirstFileRow, lngDstLastCol), _
                                 .Cells(lngDstLastRow, lngDstLastCol))

            ''CHECKPOINT: make sure we have correctly identified
            ''the range where our file names will go
            'wksDst.Range("A1").Select
            'rngFile.Select

            'Now that we have that range identified,
            'we write the file name
            rngFile.Value = wbkSrc.Name

        End With

        'Close the source workbook and repeat
        wbkSrc.Close SaveChanges:=False

    Next lngIdx

    'Let the user know that the combination is done!
    ''MsgBox "Data combined!"

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last column
'OUTPUT      : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    LastOccupiedColNum = lng
End Function

Answer 1

很抱歉回答我自己的问题，但经过一些调试后我发现了它。下面的代码不会附加，并根据您的需要创建excel。根据需要更改值，或者如果需要追加则使用原始代码。

Option Explicit
    Public Sub CombineManyWorkbooksIntoOneWorksheet()

        Dim strDirContainingFiles As String, strFile As String, _
            strFilePath As String
        Dim wbkDst As Workbook, wbkSrc As Workbook
        Dim wksDst As Worksheet, wksSrc As Worksheet
        Dim lngIdx As Long, lngSrcLastRow As Long, _
            lngSrcLastCol As Long, lngDstLastRow As Long, _
            lngDstLastCol As Long, lngDstFirstFileRow As Long
        Dim rngSrc As Range, rngDst As Range, rngFile As Range
        Dim colFileNames As Collection
        Set colFileNames = New Collection

        'Set references up-front
        strDirContainingFiles = "C:\Users\Guide\" '<~ your folder
        Set wbkDst = Workbooks.Add '<~ Dst is short for destination
        Set wksDst = wbkDst.ActiveSheet

        'Store all of the file names in a collection
        strFile = Dir(strDirContainingFiles & "\*.xlsm")
        Do While Len(strFile) > 0
            colFileNames.Add Item:=strFile
            strFile = Dir
        Loop

        ''CHECKPOINT: make sure colFileNames has the file names
        'Dim varDebug As Variant
        'For Each varDebug In colFileNames
        '    Debug.Print varDebug
        'Next varDebug

        'Now we can start looping through the "source" files
        'and copy their data to our destination sheet
        For lngIdx = 1 To colFileNames.Count

            'Assign the file path
            strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)

            'Open the workbook and store a reference to the data sheet
            Set wbkSrc = Workbooks.Open(strFilePath)
            Set wksSrc = wbkSrc.Worksheets("Sheet1")

            'Identify the last row and last column, then
            'use that info to identify the full data range
            lngSrcLastRow = LastOccupiedRowNum(wksSrc)
            lngSrcLastCol = LastOccupiedColNum(wksSrc)
            With wksSrc
            Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, _
                                                         lngSrcLastCol))
            End With

            ''CHECKPOINT: make sure we have the full source data range
            'wksSrc.Range("A1").Select
            'rngSrc.Select

            'If this is the first (1st) loop, we want to keep
            'the header row from the source data, but if not then
            'we want to remove it


            ''CHECKPOINT: make sure that we remove the header row
            ''from the source range on every loop that is not
            ''the first one
            'wksSrc.Range("A1").Select
            'rngSrc.Select

            'Copy the source data to the destination sheet, aiming
            'for cell A1 on the first loop then one past the
            'last-occupied row in column A on each following loop
            If lngIdx = 1 Then
                lngDstLastRow = 1
                Set rngDst = wksDst.Cells(1, 1)
            Else
                lngDstLastRow = 1
                Set rngDst = wksDst.Cells(1, 20)
            End If
            rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste




            'Close the source workbook and repeat
            wbkSrc.Close SaveChanges:=False

        Next lngIdx

        'Let the user know that the combination is done!
        ''MsgBox "Data combined!"

    End Sub

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'INPUT       : Sheet, the worksheet we'll search to find the last row
    'OUTPUT      : Long, the last occupied row
    'SPECIAL CASE: if Sheet is empty, return 1
    Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
        Dim lng As Long
        If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
            With Sheet
                lng = .Cells.Find(What:="*", _
                                  After:=.Range("A1"), _
                                  Lookat:=xlPart, _
                                  LookIn:=xlFormulas, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlPrevious, _
                                  MatchCase:=False).Row
            End With
        Else
            lng = 1
        End If
        LastOccupiedRowNum = lng
    End Function

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'INPUT       : Sheet, the worksheet we'll search to find the last column
    'OUTPUT      : Long, the last occupied column
    'SPECIAL CASE: if Sheet is empty, return 1
    Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
        Dim lng As Long
        If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
            With Sheet
                lng = .Cells.Find(What:="*", _
                                  After:=.Range("A1"), _
                                  Lookat:=xlPart, _
                                  LookIn:=xlFormulas, _
                                  SearchOrder:=xlByColumns, _
                                  SearchDirection:=xlPrevious, _
                                  MatchCase:=False).Column
            End With
        Else
            lng = 1
        End If
        LastOccupiedColNum = lng
    End Function

Answer 2

您应该识别您编程必须执行的各个任务，并创建处理这些较小任务的方法和函数。这样做可以让您轻松调试代码。

get1stCellInNextColumn - 定义目标范围
getFileCollection - 收集所有文件路径
getLastUsedCell - 获取范围中最后使用的单元格。用于定义源范围和目标范围
getSourceRange - 获取源范围
InsertData - 打开源文件并将其数据复制到目标工作簿
Main_CombineManyWorkbooksIntoOneWorksheet - 处理所有文件

Option Explicit

'This is the Main function that combines all the other Subs and Functions together to process the data

Public Sub Main_CombineManyWorkbooksIntoOneWorksheet()
    Application.ScreenUpdating = False
    Const FOLDERNAME As String = "C:\Users\best buy\Downloads\_Temp\" ' "C:\Users\Guide\"
    Const EXTENSION As String = "\*.xlsx" '"\*.xlsm"
    Dim cFiles As Collection
    Dim x As Long

    Set cFiles = getFileCollection(FOLDERNAME, EXTENSION)

    With Workbooks.Add

        For x = 1 To cFiles.Count
            InsertData cFiles.Item(x), .Worksheets(1)
        Next

    End With
    Application.ScreenUpdating = True
End Sub

'Opens Source Workbook, Copies Data to Target Worksheet and then closes the Source Workbook
Public Sub InsertData(SourceWBName As String, TargetWS As Worksheet)
    Dim rSource As Range

    With Workbooks.Open(SourceWBName)
        Set rSource = getSourceRange(.Worksheets("Sheet1"))
        If rSource Is Nothing Then
            Debug.Print .FullName, "No Data Found"
        Else
            rSource.Copy get1stCellInNextColumn(TargetWS.UsedRange)
        End If

        .Close SaveChanges:=False
    End With
End Sub

'Collects the full file paths for the Source workbooks
Function getFileCollection(FOLDERNAME As String, FileExtension As String) As Collection
    Dim FileName As String
    Dim col As Collection
    Set col = New Collection
    'Store all of the file names in a collection
    FileName = Dir(FOLDERNAME & FileExtension)
    Do While Len(FileName) > 0
        col.Add Item:=FOLDERNAME & FileName
        FileName = Dir
    Loop
    Set getFileCollection = col
End Function

'Gets the Source range from a Worksheet
Function getSourceRange(xlWS As Worksheet) As Range
    Dim rLastCell As Range
    With xlWS
        Set rLastCell = getLastUsedCell(.UsedRange, True, True)

        If Not rLastCell Is Nothing Then Set getSourceRange = .Range(.Cells(1, 1), rLastCell)

    End With
End Function

'Gets the first cell in the next unused Column of the Target range
Function get1stCellInNextColumn(Target As Range) As Range
    Dim r As Range
    'Get last used cell in last used column of the Target range
    Set r = getLastUsedCell(Target, False, True)

    If r Is Nothing Then
        Set r = Target.EntireColumn.Cells(1, 1)
    Else
        'Get the first cell in the next column adjacent to the Target range
        Set r = Target.Columns(Target.Columns.Count).Next
    End If

    Set get1stCellInNextColumn = r
End Function

'Gets the last used cell the last used row
'Or the last used cell the last used column
'Or the last used cells in the Target range

Function getLastUsedCell(Target As Range, InRow As Boolean, InColumn As Boolean) As Range
    Dim rRow As Range, rColumn As Range
    If Target Is Nothing Then Exit Function

    With Target

        Set rRow = .Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)

        If rRow Is Nothing Then Exit Function

        Set rColumn = .Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)

        If InRow And InColumn Then                    'Get last used cell in last used column
            Set getLastUsedCell = Intersect(rRow.EntireRow, rColumn.EntireColumn)
        ElseIf InRow Then                             'Get last used cell in last used row
            Set getLastUsedCell = rRow
        ElseIf InColumn Then                          'Get last used cell in last used column
            Set getLastUsedCell = rColumn
        End If

    End With

End Function

如何从实际起始值组合工作簿（无附加）

2 个答案: