☰

数据未复制到同一行（多个工作簿复制到主表）

tag-icon • tag-icon microsoft-excel vba
数据未复制到同一行（多个工作簿复制到主表）

我有一个 VBA 例程，用于将选定的单元格从多个工作簿复制到一个主文件。但它有一个问题，即一个或多个源（输入）工作簿可能包含空单元格。因此，当复制后续输入的数据时，它将向上移动以填充所有空白列，而不是位于同一行。如果我的措辞不清楚，请原谅；英语不是我的母语。我在这里附上了一个例子：

输入

        B3    B4     B5     B6      C9
book1   bb   1234    cc
book2   ff   3242    ff
book3   fjn  7643    jk    fjnnD   fjnnE
book4   gwd  9754    jk    gjwdD   gjwdE

预期结果（在主文件中）

        A     B      C      D       E
Row 1   bb   1234    cc     
Row 2   ff   3242    ff     
Row 3   fjn  7643    jk    fjnnD   fjnnE
Row 4   gwd  9754    jk    gjwdD   gjwdE

我得到的结果

        A     B      C      D       E
Row 1   bb   1234    cc    fjnnD   fjnnE
Row 2   ff   3242    ff    gjwdD   gjwdE
Row 3   fjn  7643    jk    
Row 4   gwd  9754    jk

这是我的代码。它包括扫描目录中的输入文件的逻辑。它工作正常，所以你可以忽略它。问题在于将数据从一个选定（打开）的工作簿复制到活动工作簿中的“主列表”工作表（引用为SummWb）的代码。

Sub UploadData()

Dim SummWb As Workbook
Dim SceWb As Workbook

'Get folder containing files
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error GoTo Error_handler
    myFolderName = .SelectedItems(1)
    'Err.Clear
    'On Error GoTo 0
End With

If Right(myFolderName, 1) <> "\" Then myFolderName = myFolderName & "\"
'Settings
Application.ScreenUpdating = False
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set SummWb = ActiveWorkbook
'Get source files and append to output file
mySceFileName = Dir(myFolderName & "*.*")

Do While mySceFileName <> "" 'Stop once all files found
    Application.StatusBar = "Processing: " & mySceFileName
    Set SceWb = Workbooks.Open(myFolderName & mySceFileName) 'Open file found
    With SummWb.Sheets("Master List")
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B3").Value
        .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B4").Value
        .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B5").Value
        .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B6").Value
        .Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C9").Value
        .Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D9").Value
        .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C10").Value
        .Cells(.Rows.Count, "L").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D10").Value
        .Cells(.Rows.Count, "M").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C11").Value
        .Cells(.Rows.Count, "N").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D11").Value
        .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Value = SummWb.Sheets("Upload Survey").Range("C8").Value
    End With
    SceWb.Close (False) 'Close Workbook
    mySceFileName = Dir
Loop
MsgBox ("Upload complete.")
'Settings and save output file
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
SummWb.Activate
SummWb.Save 'save automaticallly
Application.ScreenUpdating = True
Exit Sub

Error_handler:
MsgBox ("You cancelled the action.")

End Sub

我猜问题出在End(xlUp)代码上。任何形式的帮助都非常感谢。

答案1

你说得对——该End(xlUp)方法有效地找到了最后一个非空白单元格在每一列中。A因此，在您的人为示例中，列和B中   的最后一个非空白单元格 是第 4 行，但列和 C中的最后一个非空白单元 格是第 2 行。您想找到最后一个DE排所有列中都有（非空白）数据。

可能有一种快速简便的方法可以做到这一点，如果有的话，我愿意学习。但这里有一个有点蛮力的方法：

首先，定义一个整型变量maxrow：

Dim maxrow As Integer

（实际上，您不需要这样做，但这是一种好的形式。）

然后，通过查看所有列并取最大值，找到任何列中包含（非空白）数据的最后一行。在块的开头With SummWb.Sheets("Master List")，执行

    maxrow = 0
    maxrow = Application.Max(maxrow, .Cells(.Rows.Count, "A").End(xlUp).Row)
    maxrow = Application.Max(maxrow, .Cells(.Rows.Count, "C").End(xlUp).Row)
    maxrow = Application.Max(maxrow, .Cells(.Rows.Count, "D").End(xlUp).Row)
    maxrow = Application.Max(maxrow, .Cells(.Rows.Count, "E").End(xlUp).Row)
      ︙

对于您使用的其他七列，也是如此。然后执行

    .Cells(maxrow + 1, "A") = SceWb.Sheets("Survey").Range("B3").Value
    .Cells(maxrow + 1, "C") = SceWb.Sheets("Survey").Range("B4").Value
    .Cells(maxrow + 1, "D") = SceWb.Sheets("Survey").Range("B5").Value
    .Cells(maxrow + 1, "E") = SceWb.Sheets("Survey").Range("B6").Value
             ︙

其他七列/值也是如此。快速说明：

  • 中+ 1的maxrow + 1取代了.Offset(1, 0)，因此您将它复制到行中以下最后一行（而不是覆盖最后一行的数据）。
  • 据我所知，您不需要.Value分配两侧的成员。我保留了右侧的成员，因为我根本不需要更改右侧。如果您喜欢冒险，请尝试删除它们。如果您发现需要左侧成员的原因（例如），请将它们放回去.Cells(maxrow + 1, "A").Value = …（并让我知道您需要这样做的原因）。

相关内容