Прокрутите несколько рабочих книг и скопируйте их в другую существующую книгу

Question

Я ищу что-то несколько сложное.У меня есть одна главная рабочая книга (имя: Verificari CE), а другие рабочие книги находятся в той же папке на рабочем столе (имя папки Verificari).Если я могу просмотреть все книги .xls из этой папки, расположенной на рабочем столе с именем «Verificari», и скопировать данные из каждой книги в эту основную книгу (Verificari CE).

Допустим, у меня есть эти книги:

• Verificari CE (основная рабочая книга)
• Тест A
• Тест B
• Тест C

Примечание:Имя и номер (Тест A; Тест B; Тест C….) этих рабочих книг будут различаться!

Вот как мне это нужно для функционирования:

• Скопируйте все строки с даннымииз Листа 1 теста А в Verificari CE.
• Затем проверьте Лист 1 теста В и скопируйте все строки с данными из А2, вставьте НИЖЕ данные кампании А в Verificari CE
• Затем проверьте Лист 1 теста С и скопируйте всестроки с данными, вставьте НИЖЕ данные Campaign B в Verificari CE

Извините, я не могу загрузить пример (я работаю в компании, чувствительной к данным).Любая помощь будет принята с благодарностью!

Sub Copymultiple()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    Dim VerificariCE As Workbook
    Dim TestA As Workbook
    Dim TestB As Workbook
    Dim TestC As Workbook

    Dim maxRow As Long
    Dim maxCol As Integer

    Dim nextRow As Long

    Set VerificariCE = Workbooks("Verificari CE.xlsm")

    With VerificariCE.Sheets(2)   
        Workbooks.Open .Cells(1, 1).Value
        Set TestA = ActiveWorkbook

        Workbooks.Open .Cells(2, 1).Value
        Set TestB = ActiveWorkbook

        Workbooks.Open .Cells(2, 1).Value
        Set TestC = ActiveWorkbook
    End With

    'Comment this out if you don't want to clear existing values
    VerificariCE.Sheets(1).UsedRange.Clear
    'Comment this out if you don't want to clear existing values

    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    With TestA.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestA.Close

    With TestB.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestB.Close

    With TestC.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestC.Close

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With

    With VerificariCE.Sheets(1).UsedRange
        .Value = .Value
        .Activate
    End With

    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub

Answer 1

Это утилита, которую я использовал в прошлом. Он имеет немного внешнего интерфейса, позволяющего выбирать файлы, которые вы хотите объединить, но он должен предоставить вам код, который вы ищете. Удачи!

Public FirstRowUsed As Integer
Sub CreateInputFile()

Dim fs, f, s
Dim PathInfo As Variant
Dim TrueVar As Variant
Dim FileToOpen() As Variant

'screen.mousepointer = fmMousePointerHourglass
Application.Cursor = xlWait
FirstRowUsed = 3
LastRowUsed = ActiveSheet.UsedRange.Rows.Count
If LastRowUsed >= FirstRowUsed Then
  ClearSheet = MsgBox("Clear Sheet?", vbOKCancel, "Current Data will be deleted")

  If ClearSheet = 1 Then
    x = Range(Cells(FirstRowUsed, 1), Cells(ActiveSheet.UsedRange.Rows.Count, 1)).Select
    Selection.EntireRow.Delete
    x = Range(Cells(FirstRowUsed, 1), Cells(FirstRowUsed, 1)).Select
    Selection.Activate
  Else
    x = MsgBox("Process Terminated, No Action Taken.", vbOKOnly)
    GoTo CreateInputFileExit
  End If
End If

TrueVar = True
FileToOpen = Application _
    .GetOpenFilename("Excel Files (*.xls;*.xlsx),*.xls;*.xlsx,(*.xlsx),*.xlsx", , "Select Files to Combine", , TrueVar)

On Local Error Resume Next

If UBound(FileToOpen) < 1 Then
  x = MsgBox("Process Terminated", vbOKOnly)
  GoTo CreateInputFileExit
Else
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set FileInfo = fs.GetFile(FileToOpen(1))
  TargetPath = fs.GetParentFolderName(FileToOpen(1))
End If

On Local Error GoTo 0

Set PathInfo = fs.Getfolder(TargetPath)

TargetPath = PathInfo.shortpath

Application.StatusBar = False

On Local Error Resume Next

Call GetFileInfo(FileToOpen())

Application.StatusBar = False
Application.ScreenUpdating = True
SendKeys "^{HOME}"  'Ctrl+Home

CreateInputFileExit:

  Application.Cursor = xlDefault

End Sub

Sub GetFileInfo(FileToOpen() As Variant)

Dim Row As Double
Dim FileCtr As Double
Dim ReportInterval As Double
Dim fs, f, s
Dim FileInfo As Variant
Dim Ext As String

On Local Error Resume Next

Set fs = CreateObject("Scripting.FileSystemObject")


Row = FirstRowUsed
ReportInterval = 100
FileCtr = 0
For i = 1 To UBound(FileToOpen)

  TotFileName = FileToOpen(i)

  DirCheck = Dir(TotFileName)
  DateOut = FileDateTime(TotFileName)
  FileLength = FileLen(TotFileName)

  If DirCheck > "" Then ' Eliminates Directory entries

    Set FileInfo = fs.GetFile(TotFileName)
    Ext = fs.GetExtensionName(TotFileName)
    Pathname = fs.GetParentFolderName(TotFileName)

    Filename = FileInfo.Name
    Cells(Row, 1) = Pathname
    Cells(Row, 2) = Filename
    Cells(Row, 3) = DateOut
    Cells(Row, 4) = FileLength
    Cells(Row, 5) = TotFileName
    Cells(Row, 6) = Ext
    Row = Row + 1
    FileCtr = FileCtr + 1


    If FileCtr Mod ReportInterval = 0 Then
      DoEvents
      Application.ScreenUpdating = True
      Cells(Row - 1, 1).Activate 'Makes the screen change a bit so the user knows it is working
      Application.ScreenUpdating = False
      Application.StatusBar = "File Names Processed so far: " & FileCtr
    End If

  End If

Next i

Application.StatusBar = False

End Sub

Sub MergeTheFiles()
Dim FileSheet As Worksheet
Dim TargetBook As Workbook
Dim SourceBook As Workbook

FileSheetNm = "FileList"
ActiveWorkbook.Worksheets(FileSheetNm).Activate

Set FileSheet = ActiveSheet
Set Targetworkbook = Workbooks.Add

MaxRow = FileSheet.UsedRange.Rows.Count

Numfiles = MaxRow - 2

For i = 3 To MaxRow
  Sourcefile = FileSheet.Cells(i, 5)
  Workbooks.Open Filename:=Sourcefile, UpdateLinks:=3, ReadOnly:=True

  Set SourceWorkBook = ActiveWorkbook
  TargetDirectory = FileSheet.Cells(i, 1)
  Application.DisplayAlerts = False
  For Each sh In SourceWorkBook.Worksheets
    ShtNm = sh.Name
    LastSheet = Targetworkbook.Worksheets.Count
    sh.Copy After:=Targetworkbook.Sheets(LastSheet)

        Set CurrSht = ActiveWorkbook.Worksheets(LastSheet + 1)
        Set TrgtSht = ActiveWorkbook.Worksheets(1)
        TrgtAddr = Cells(TrgtSht.UsedRange.Rows.Count + 1, 1).Address

    With CurrSht

        lRow = .Cells.Find(What:="*", _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

        lCol = .Cells.Find(What:="*", _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column

        .Range(.Cells(1, 1), .Cells(lRow, lCol)).Copy Destination:=TrgtSht.Range(TrgtAddr)
    End With

    CurrSht.Delete

  Next sh

  Application.DisplayAlerts = True
  SourceWorkBook.Close SaveChanges:=False

Next i


    DateOfFile = Format(Date$, "yyyy-mm-dd")

    TargetFileName = "$Date XYZ"

    TargetFileName = Application.WorksheetFunction.Substitute(TargetFileName, "$Date", DateOfFile)
    fileSaveName = Application.GetSaveAsFilename( _
    InitialFilename:=TargetFileName, _
    fileFilter:="Excel Files (*.xlsx), *.xlsx")
    NewFileNameAndDir = fileSaveName
    If InStr(UCase(NewFileNameAndDir), ".XLS") = 0 Then
      If Right(NewFileNameAndDir, 1) = "." Then
        NewFileNameAndDir = NewFileNameAndDir & "xlsx"
      Else
        NewFileNameAndDir = NewFileNameAndDir & ".xlsx"
      End If
    End If

    ActiveWorkbook.SaveAs Filename:=NewFileNameAndDir, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

    With Application
        .Calculation = xlManual
        .MaxChange = 0.001
    End With
    ActiveWorkbook.PrecisionAsDisplayed = False

   With Application
        .Calculation = xlAutomatic
        .MaxChange = 0.001
    End With
    ActiveWorkbook.PrecisionAsDisplayed = False

    ActiveWorkbook.Save

End Sub
'''

Answer 2

Избегайте использования выбора.Используйте переменные объекта, чтобы указать на ваши объекты.Используйте DIR для чтения файлов в вашей папке.

Sub Example()
const foldername = "Verificari"
const mastername = "Verificari CE.xlsm"
Dim wb as workbook
Dim ws as Worksheet
Dim targetbook as workbook
Set targetbook = workbooks(mastername) 'I assume this code is in this file and it is therefore open
Dim targetsheet as worksheet
set targetsheet = worksheets(1) 'assume first sheet
Dim target as range
set target = targetsheet.range("a2")
Dim r as range
Dim s as string
s = dir(foldername & "*.xl*")  'read spreadsheet names
do while s <> ""
   if s = mastername then
   else
   set wb = workbooks.open(foldername & "\" & s)
   if not wb is nothing then
      set ws = wb.worksheets(1)
     '#########
      set r = targetsheet.range("a" & rows.count).end(xlup).offset(1,0)
      ws.usedrange.copy r
      '##########
      wb.close false
   end if
   end if   'missed this first time round
   s = dir()
loop
end sub

Я не могу проверить это, поэтому возможны опечатки