Question

我对这类工作非常陌生，并且在网上找到了该VBA。当前，它设置为将数据从多个外部Excel工作簿提取到单个工作簿中，每个工作簿都在其自己的NEW工作表上。相反，我需要它来替换标记为“ QDS”，“ QDS（2）”，“ QDS（3）”等的现有工作表，以此类推，直到“ QDS（23）”（只是不替换第一个工作表），这是我所有公式所在的位置。谁能帮我弄清楚该怎么做？提前非常感谢！

Sub MergeExcelFiles()
   Dim fnameList, fnameCurFile As Variant
   Dim countFiles, countSheets As Integer
   Dim wksCurSheet As Worksheet
   Dim wbkCurBook, wbkSrcBook As Workbook

   fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

   If (vbBoolean <> VarType(fnameList)) Then

       If (UBound(fnameList) > 0) Then
           countFiles = 0
           countSheets = 0

           Application.ScreenUpdating = False
           Application.Calculation = xlCalculationManual

           Set wbkCurBook = ActiveWorkbook

           For Each fnameCurFile In fnameList
               countFiles = countFiles + 1

               Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

               For Each wksCurSheet In wbkSrcBook.Sheets
                   countSheets = countSheets + 1
                   wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
               Next

               wbkSrcBook.Close SaveChanges:=False

           Next

           Application.ScreenUpdating = True
           Application.Calculation = xlCalculationAutomatic

           MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
       End If

   Else
       MsgBox "No files selected", Title:="Merge Excel files"
   End If
End Sub

Answer 1

也许尝试这样的事情：

Dim done As Boolean
'....
'....
For Each fnameCurFile In fnameList
    countFiles = countFiles + 1

    Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

    For Each wksCurSheet In wbkSrcBook.Sheets
        countSheets = countSheets + 1
        'check have somewhere to paste the content...
        If countSheets > 23 Then
            MsgBox "Reached max. sheet count of 23!", vbExclamation
            done = True
            Exit For
        End If
        'copy the sheet content, not the actual sheet....
        '   skip the formulas sheet
        wksCurSheet.UsedRange.Copy ThisWorkbook.Sheets(countSheets + 1).Range("A1")
    Next

    wbkSrcBook.Close SaveChanges:=False
    If done Then Exit For
Next
'....
'....

调整VBA代码，以便外部文件替换现有工作表

1 个答案: