Question

我找到了以下代码，它给了我多个文件的第一列，并将它们全部放在一个工作簿中。我的问题是：如何告诉这个宏给我多个列，并将它们放在一个工作簿中？同样，不是复制所有的每个文件，这个宏似乎停止了一段时间，可能是因为有合并的单元格或额外的空格。我想知道是否有一种简单的方法来修改它，以便它肯定地到达文档的底部。所有文件的格式都相同。

 Private Declare Function SetCurrentDirectoryA Lib _
         "kernel32" (ByVal lpPathName As String) As Long

    Sub ChDirNet(szPath As String)
         SetCurrentDirectoryA szPath
     End Sub

    Sub Combine_Workbooks_Select_Files()
         Dim MyPath 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
         Dim SaveDriveDir As String
         Dim FName As Variant

        With Application
             CalcMode = .Calculation
             .Calculation = xlCalculationManual
             .ScreenUpdating = False
             .EnableEvents = False
         End With

        SaveDriveDir = CurDir
         ChDirNet "C:\"

        FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                             MultiSelect:=True)
         If IsArray(FName) Then
             Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
             rnum = 1
             For Fnum = LBound(FName) To UBound(FName)
                 Set mybook = Nothing
                 On Error Resume Next
                 Set mybook = Workbooks.Open(FName(Fnum))
                 On Error GoTo 0
                 If Not mybook Is Nothing Then
                     On Error Resume Next
                     With mybook.Worksheets(1)
                         Set sourceRange = .Range("A1:A25")
                     End With
                     If Err.Number > 0 Then
                         Err.Clear
                         Set sourceRange = Nothing
                     Else
             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 "Not enough rows in the sheet. "
                             BaseWks.Columns.AutoFit
                             mybook.Close savechanges:=False
                             GoTo ExitTheSub
                         Else
                             Set destrange = BaseWks.Range("A" & rnum)
                             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:
         With Application
             .ScreenUpdating = True
             .EnableEvents = True
             .Calculation = CalcMode
         End With
         ChDirNet SaveDriveDir
     End Sub

Answer 1

您提供的代码使用变量sourceRange来确定要使用的范围。您只看到部分列被复制的原因是因为sourceRange被硬编码到范围A1:A25。

因此，如果您希望代码使用多个列并转到工作表的末尾，则需要更改设置sourceRange的代码。这样的事情应该有效：

'Put these declarations at the top with the others
Dim lastCol As Long
Dim lastRow As Long

将Set sourceRange = .Range("A1:A25")代码替换为以下内容：

'Use the headers to determine the last column
lastCol = .Rows("1:1").Find("*", searchdirection:=xlPrevious).Column

'Find the last row in column A
lastRow = .Range("A:A").Find("*", searchdirection:=xlPrevious).Row

'Set sourceRange using the lastRow and lastCol variables
Set sourceRange = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))

修改

searchdirection:=xlPrevious表示Find方法从右到左搜索列（或从下到上搜索行）。上面的代码会搜索xlPrevious，直到找到任何值（使用*通配符）。

如果您的标头已合并，则Find方法会将最左侧列作为最后使用的列而不是实际上次使用的列返回。例如，如果合并了I1和J1，则上述代码将返回列I作为最后使用的列。

要解决此问题，我们可以使用MergeArea对象的Range属性：

If Rows("1:1").Find("*", searchdirection:=xlPrevious).MergeArea.Columns.Count > 1 Then lastCol = Rows("1:1").Find("*", searchdirection:=xlPrevious).Column + _ Rows("1:1").Find("*", searchdirection:=xlPrevious).MergeArea.Columns.Count - 1 Else: lastCol = Rows("1:1").Find("*", searchdirection:=xlPrevious).Column End If

在上面的例子中，我们检查找到的最后一个使用的列是否是合并区域的一部分（如果列数大于1），如果是，我们找到像之前一样的最后一列，但是我们计算合并区域中的列，并将这些列添加到最后一列。

使用上面的示例替换代码中的lastCol =行，即使使用合并列，您也应该能够找到最后一列。

修改代码以复制多个列并处理合并列

1 个答案: