Настройка кода VBA, чтобы внешние файлы заменяли существующие таблицы - PullRequest
0 голосов
/ 26 октября 2018

Я очень новичок в этом виде работы и нашел этот VBA онлайн. В настоящее время он настроен на извлечение данных из нескольких внешних рабочих книг Excel в одну рабочую книгу, каждая из которых находится на отдельной новой рабочей таблице. Вместо этого мне нужно заменить существующие листы с метками «QDS», «QDS (2)», «QDS (3)» и т. Д. До «QDS (23)» (просто НЕ заменять 1-й лист) , где все мои формулы). Может кто-нибудь помочь мне понять, как это сделать? Большое спасибо заранее !!

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

1 Ответ

0 голосов
/ 27 октября 2018

Может быть попробовать что-то вроде этого:

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
'....
'....
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...