宏循环遍历除前两个以​​外的所有工作表，并将一个单元格和范围复制到另一个工作簿中

Question

我有一个主工作簿，已经可以浏览文件夹中的所有文件。但是，选项卡之一需要浏览另一个选定的工作簿“数据”中的所有选项卡。该工作簿大约有30个工作表，除了“投资”和“基金”外，我需要遍历每个工作表。如果方便的话，这些是工作簿中的前两个选项卡。然后，我需要在每个工作表中复制单元格F9，将其粘贴到不同的工作簿“主”单元格“ C4”中，返回到“数据”工作簿中的同一工作表，然后复制范围“ C16：C136”并将其粘贴到单元格中“主”工作簿的“ E4”。然后，它将需要循环到“数据”工作簿中的下一个工作表并继续循环。对于每个新工作表，我需要将其粘贴到“主”文件中的下一行。即第二个工作表将粘贴在“ C5”和“ E5”中。

如果更容易，我可以将其拆分为两个宏。然后，只需将工作表中的所有数据粘贴到数据工作簿中的新空白表中，然后我就可以再将其复制到“主”工作簿中。

预先感谢

$data->employer

Answer 1

请向我们展示您的首次尝试。随时添加

之类的评论

' I need this to do XXXX here, but I don't know how 

以下是一些提示：

要遍历工作簿中的所有工作表，请使用：

For each aSheet in MyWorkbook.Sheets

要跳过某些特定的表格，请说：

If aSheet.Name <> "Investments" And aSheet.Name <> "Funds"

要从aSheet复制到MasterSheet，请先设置初始目的地：

set rSource = aSheet.range("F9")
set rDestin = MasterSheet.range("C4")

然后在循环中进行复制：

rDestin.Value = rSource.Value

...并设置下一组位置

set rSource = rSource.offset(1,0)
set rDestin = rDestin.offset(1,0)

有帮助吗？

编辑：简要查看您的版本，我认为这部分无效：

If ws.Name <> "Funds" And ws.Name <> "Investments" Then

Next ws

您不想删除最后一行吗？

编辑2：您经常使用它：

wb.Worksheets.<something>

但这并不涉及特定的工作表。您要使用“ ws”，如下所示：

ws.Range("F9")

大编辑：

仔细浏览此版本，并查看其工作原理：

Sub ImportInformation()
    WorksheetLoop
End Sub

Function WorksheetLoop()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim foundCell As Range
    Dim strFind As String
    Dim fRow, fCol As Integer

    '*** Adding Dims:
    Dim wf, FilePicker
    Dim NOI As Worksheet
    Dim myPath As String
    Dim PasteRow As Long

    'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' This allows you to use excel functions by typing wf.<function name>
    Set wf = WorksheetFunction

    'Set the name of your output file, I assume its fixed in the Master File
    'Please note that I am running this out of the master file and I want it all in the Noi tab
    Set NOI = ThisWorkbook.Worksheets("NOI")


    'Retrieve Target File Path From User
    '    Set FilePicker = Application.FileDialog(msoFileDialogFolderPicker)

    'This only selects a folder, however I would like it to select a SPECIFIC FILE
    '    With FilePicker
    '       .Title = "Select A Target Folder"
    '      .AllowMultiSelect = False
    '     If .Show <> -1 Then GoTo NextCode
    '    myPath = .SelectedItems(1) & "\"
    ' End With


   Dim WorkbookName As Variant
    ' This runs the "Open" dialog box for user to choose a file
    WorkbookName = Application.GetOpenFilename( _
               FileFilter:="Excel Workbooks, *.xl*", Title:="Open Workbook")

    Set wb = Workbooks.Open(WorkbookName)

    ' initialize the starting cell for the output file
    PasteRow = 4

    'I need this to be referring to the file that I choose
    For Each ws In wb.Worksheets

        If ws.Name <> "Funds" And ws.Name <> "Investments" Then

        ' **** Leave this out:   Next ws

        ws.Range("F9").Copy                      '<--- You mean this, not wb.Worksheets.Range.("F9").Copy
        NOI.Range("C" & PasteRow).PasteSpecial xlPasteValues, Transpose:=False

        'Get find String
        strFind = NOI.Range("C2").Value

        'Find string in Row 16 of each row of current ACTIVE worksheet
        Set foundCell = ws.Range("A16:IT16").Find(strFind, LookIn:=xlValues)

        'If match cell is found
        If Not foundCell Is Nothing Then

            'Get row and column
            fRow = foundCell.Row
            fCol = foundCell.Column

            'Copy data from active data worksheet “data” and copy over 300 columns (15 years).
            ' This is needed to find what specific date to start at.  This portion works, I just need it to loop through each worksheet.
            ws.Range(Cells(fRow + 1, fCol).Address & ":" & Cells(fRow + 1, fCol + 299).Address).Copy

            'Paste in NOI tab of mater portfolio
            NOI.Range("E" & PasteRow).PasteSpecial xlPasteValues, Transpose:=False

           '*** Move PasteRow down by one
            PasteRow = PasteRow + 1

            wb.Application.CutCopyMode = False

        Else

            Call MsgBox("Try Again!", vbExclamation, "Finding String")

        End If
    End If
Next ws

    wb.Close SaveChanges:=False
End Function