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

从新的电子表格和格式中跨多个选项卡检索相同的设置单元格值

1 个答案: