在VBA中將所有工作表數據復制到另一個工作簿中的特定工作表

Question

請幫忙。 一直在看這個和搜索網站2天。 我有一個摘要文件“mysumwb”的文件。 我打開文件夾中的所有文件。 “LsWb”表示打開的文件。 搜索名為“LsFileSh”的特定工作表。 並將整個工作表“LsFileSh”的值復制/粘貼到摘要文件的最后一個工作表中。 實際發生的是將工作表復制到目標/摘要文件“mysumwb”中的所有工作表上。

這是代碼。 對不起，所有評論。 謝謝你

 Sub Summarize_Reports()
'Mar 18, 2019
On Error Resume Next

Const shN = "Sheet Format"                               '<< summary workbook sheet name
Const LsFileSh = "1. Summary for Reporting "             '<< summary workbook sheet name

Dim wb As Workbook
Set mysumwb = ThisWorkbook                               '<< The summary WB
Dim SumWs As Worksheet
Set SumWs = ThisWorkbook.Sheets(shN)                     '<< The summary workbook sheet, "Summary Format"


Dim CountSh As Long, r As Long, c As Long
Dim A As Long
Dim myPath As String
Dim myFile As String
Dim LsWb As Workbook        '<< This is the leasing file WB identifierDim fldr As FileDialog
Dim LsFileName As String

Application.ScreenUpdating = False

'***********************************This With statement selects the folder

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Please select the folder where the Capital lease files are, then press OK to continue"
.AllowMultiSelect = False
    If .Show <> -1 Then
    Set fldr = Nothing
    Else
    myPath = .SelectedItems(1)
    End If

    If Right(myPath, 1) <> "\" Then
    myPath = myPath & "\"
    End If
End With

myFile = Dir(myPath & "*capital*.xl*")

'MsgBox mysumwb.Name
'MsgBox mysumwb.Worksheets.Count
CountSh = mysumwb.Worksheets.Count
'MsgBox CountSh

Do While myFile <> ""


    Sheets("Summary Format").Select                      '<<<<<< copy the tab in the sumwp file
    Sheets("Summary Format").Copy After:=Sheets(CountSh)

    'mysumwb.SumWs.Select
    'mysumwb.SumWs.Copy After:=mysumwb.workheets(CountSh)

    Set LsWb = Workbooks.Open(myPath & myFile)           '<<< establish the open leasing file's name
    LsFileName = Left(LsWb.Name, Len(LsWb.Name) - 4)     '<<< move the filename to a string
    mysumwb.Sheets(CountSh + 1).Name = LsFileName

    LsWb.Sheets(LsFileSh).Activate
 '   LsWb.Sheets(LsFileSh).Cells.Copy
 '   mysumwb.Sheets(Worksheets.Count).Cells.Value = LsWb.Sheets(LsFileSh).Cells.Value

    With mysumwb

        CountSh = mysumwb.Worksheets.Count
        MsgBox CountSh
        .Sheets(CountSh).Name = LsFileName
        .Sheets(LsFileName).Activate
        .Sheets(LsFileName).Range("A1").PasteSpecial Paste:=xlPasteValues
        MsgBox LsFileName
    End With

'    MsgBox ActiveWorkbook.Name
'    mysumwb.Sheets(LsFileName).Select
'    MsgBox ActiveWorkbook.Worksheets(CountSh + 1).Name
'
'
'
'    mysumwb.Sheets(LsFileName).Range("A1").PasteSpecial Paste:=xlPasteValues


    Application.CutCopyMode = False


    LsWb.Close False
    myFile = Dir()
    mysumwb.Save
Loop


ActiveWorkbook.Save
Application.ScreenUpdating = True
NoFilesProcessed.Value = "Lease Files Processed = " & A
MsgBox A
MsgBox "All Done!"


On Error GoTo 0
End Sub

Answer 1

我測試了以下代碼，它適用於我。 你下次使用錯誤恢復的方式不是一個好主意，因為你的代碼會返回很多錯誤。 我刪除它並修復錯誤，我自己的測試運行成功。 如果您運行代碼，請告訴我您是否遇到任何錯誤。 以及錯誤是什么。

Sub Summarize_Reports()
'Mar 18, 2019


Const shN = "Sheet Format"                               '<< summary workbook sheet name
Const LsFileSh = "1. Summary for Reporting "             '<< summary workbook sheet name

Dim wb As Workbook
Set MySumWb = ActiveWorkbook                               '<< The summary WB
Dim SumWs As Worksheet
Set SumWs = ActiveWorkbook.Sheets(shN)                     '<< The summary workbook sheet, "Summary Format"


Dim CountSh As Long, r As Long, c As Long
Dim A As Long
Dim myPath As String
Dim myFile As String
Dim LsWb As Workbook        '<< This is the leasing file WB identifierDim fldr As FileDialog
Dim LsFileName As String

Application.ScreenUpdating = False

'***********************************This With statement selects the folder

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Please select the folder where the Capital lease files are, then press OK to continue"
.AllowMultiSelect = False
    If .Show <> -1 Then
    Set fldr = Nothing
    Else
    myPath = .SelectedItems(1)
    End If

    If Right(myPath, 1) <> "\" Then
    myPath = myPath & "\"
    End If
End With

myFile = Dir(myPath & "*capital*.xl*")

'MsgBox mysumwb.Name
'MsgBox mysumwb.Worksheets.Count
CountSh = MySumWb.Worksheets.Count
'MsgBox CountSh

Do While myFile <> ""


    MySumWb.Worksheets("Summary Format").Select                      '<<<<<< copy the tab in the sumwp file
    MySumWb.Worksheets("Summary Format").Copy After:=Sheets(CountSh)

    'mysumwb.SumWs.Select
    'mysumwb.SumWs.Copy After:=mysumwb.workheets(CountSh)

    Set LsWb = Workbooks.Open(myPath & myFile)           '<<< establish the open leasing file's name
    LsFileName = Left(LsWb.Name, Len(LsWb.Name) - 4)     '<<< move the filename to a string
    MySumWb.Sheets(CountSh + 1).Name = LsFileName

    LsWb.Sheets(LsFileSh).Activate
    LsWb.Sheets(LsFileSh).Cells.Copy

    MySumWb.Sheets(LsFileName).Range("A1").PasteSpecial Paste:=xlPasteValues



'    MsgBox ActiveWorkbook.Name
'    mysumwb.Sheets(LsFileName).Select
'    MsgBox ActiveWorkbook.Worksheets(CountSh + 1).Name
'
'
'
'    mysumwb.Sheets(LsFileName).Range("A1").PasteSpecial Paste:=xlPasteValues


    Application.CutCopyMode = False


    LsWb.Close False
    myFile = Dir()
    MySumWb.Save
Loop


ActiveWorkbook.Save
Application.ScreenUpdating = True
MsgBox A
MsgBox "All Done!"



End Sub