时间戳

首页 > 解决方案 > 从新的电子表格和格式中跨多个选项卡检索相同的设置单元格值

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

问题描述

需要从多个业务实体电子表格中复制和粘贴设置单元格数据并匹配主电子表格的格式。

需要在工作簿的每个选项卡中复制和粘贴设置单元格，并使用特定格式的数据填充主电子表格 - 所以我每次都希望从新工作簿中复制相同的单元格。（表 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 知识非常有限，因此非常感谢任何建议。在运行宏之前是否需要保存每个业务实体电子表格？以前我只是提取我​​需要的东西并关闭。为问题的长度道歉。

标签： excelvba

解决方案

我想你想要这样的东西：

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

推荐阅读