Извлечение одинаковых значений набора ячеек на нескольких вкладках из новых электронных таблиц и форматирования

Question

Необходимость копирования и вставки данных набора ячеек из нескольких таблиц бизнес-объектов и соответствия формату основной таблицы.

Необходимо скопировать и вставить установленные ячейки на каждой вкладке рабочей книги и заполнить основную электронную таблицу данными в определенном формате - поэтому я буду стараться каждый раз копировать одни и те же ячейки из новых рабочих книг.(Лист 1 = Счет, C2, C6. Лист 3 = Ценообразование и комиссия, B5, B7 и т. Д.), А затем автоматически отформатируйте его в макет основной таблицы.

Это выглядит ближе всего к моим потребностям, но я не уверен, как их адаптировать.

    Sub Consolidate()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range


    Set destsheet = ThisWorkbook.Worksheets("Sheet1")
    Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
                       .Offset(1, 0).EntireRow
    Fname = Dir(ThisWorkbook.Path & "/*.xlsx")

    'loop through each file in folder (excluding this one)
    Do While Fname <> "" And Fname <> ThisWorkbook.Name

        If Fname <> ThisWorkbook.Name Then

            Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
            Set originsheet = wkbkorigin.Worksheets("Sheet1")

            With RngDest
                .Cells(1).Value = originsheet.Range("E9").Value
                .Cells(2).Value = originsheet.Range("D18").Value
                .Cells(3).Value = originsheet.Range("D22").Value
                .Cells(4).Value = originsheet.Range("E11").Value
                .Cells(5).Value = originsheet.Range("F27").Value
            End With

            wkbkorigin.Close SaveChanges:=False   'close current file
            Set RngDest = RngDest.Offset(1, 0)

        End If

        Fname = Dir()     'get next file
    Loop
End Sub


Do While Fname <> "" And Fname <> ThisWorkbook.Name
    Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
    For Each ws in wkbkorigin.Worksheets '### YOU NEED TO ITERATE OVER SHEETS IN THE WORKBOOK THAT YOU JUST OPENED ON THE PRECEDING LINE
        With ws
            ' Do something with the ws Worksheet, like take the values from D3 and E9 and put them in your RngDest range:
             RngDest.Cells(1,1).Value = .Range("D3").Value
             RngDest.Cells(1,2).Value = .Range("E9").Value
        End With
        Set RngDest = RngDest.Offset(1, 0) '## Offset this range for each sheet so that each sheet goes in a new row
    Next
    wkbkorigin.Close SaveChanges:=False   'close current file
    Fname = Dir()     'get next file

Мои знания VBA очень ограничены, поэтому любые советы будут высоко оценены.Нужно ли сохранять каждую таблицу бизнес-объекта перед запуском макроса?Раньше я просто извлекал то, что мне нужно, и закрывал.Извиняюсь за длину вопроса.

Answer 1

Я думаю, вы хотите что-то вроде этого:

Option Explicit
Public Sub Transfer_Data()
On Error Resume Next
        Dim wsMaster As Worksheet
        Dim wbSource As Workbook
        Dim wsSource As Worksheet
        Dim intChoice As Integer
        Dim strPath As String

        'turn off screen blinking to make code faster and less annoying
        Application.ScreenUpdating = False
        'Set the wsMaster to the sheet you want to add data to
        Set wsMaster = ActiveWorkbook.Sheets("Sheet1")
        'only allow the user to select one file
        Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
        'make the file dialog visible to the user
        intChoice = Application.FileDialog(msoFileDialogOpen).Show
        'determine what choice the user made
        If intChoice <> 0 Then
            'get the file path selected by the user
            strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
            'open the file
            Set wbSource = Workbooks.Open(strPath)
        End If
        'Then you would loop through each worksheet like this and copy whatever information you want to wherever you want on your original sheet
        For Each wsSource In wbSource.Worksheets
            'set the values of the cells equal to its corresponding cell in the opened worksheet (copy and paste will be slower and more of a hassle unless you want cell color etc also)
            'format of cells: .cells('rownubmer', 'colnumber')
            wsMaster.Cells(3, 2).Value = wsSource.Cells(1, 2).Value
        Next
        'close file without saving
        wbSource.Close (False)
        'turn screen updating back on
        Application.ScreenUpdating = True
        'goto master sheet
        wsMaster.Activate
End Sub