Excel 将数据从一张图纸复制并粘贴到多张图纸，其中范围与图纸名称匹配

我有一个API调用，可以提取与34个单独站点相关的数据。每个站点都有不同数量的资产，每个资产都有一个唯一的标识符

我正在尝试编写一个宏，将特定站点的数据复制并粘贴到文件中各自的工作表中。我熟悉这方面的基本概念，但我正在努力确定需要指定的范围

因此，基本上，我需要宏沿着称为“原始数据”的工作表A列向下运行，并识别A列中的站点名称值与其中一个工作表名称匹配的任何行。然后，它应将具有该站点名称的行从A复制到H，并粘贴到A到H行中的相应站点工作表中

列A中的值将始终与工作簿中的其他工作表之一相匹配

可能有助于更好地解释的示例图像：

如果我的解释不太清楚，请提前道歉。我使用宏的经验非常有限，所以我不确定我解释我想要实现的目标的方式是可以理解的还是完全可能的

不过，我非常渴望学习，非常感谢你们这些优秀的人提供的任何指导。

欢迎

试试这个

Function ChkSheet(SheetName As String) As Boolean

    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = SheetName Then
            ChkSheet = True
            Exit Function
        End If
    Next

    ChkSheet = False

End Function

Sub test()
Dim i, j, k As Long
Dim wsRaw As Worksheet
Dim Aux As String

Set wsRaw = Worksheets("Raw Data")

For i = 1 To wsRaw.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
    If ChkSheet(wsRaw.Cells(i, 1).Value2) Then
        Aux = wsRaw.Cells(i, 1).Value2
        k = Worksheets(Aux).Range("A:A").SpecialCells(xlCellTypeLastCell).Row + 1
        For j = 1 To 8
            Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
        Next
    Else
        Worksheets.Add.Name = wsRaw.Cells(i, 1).Value2
        Aux = wsRaw.Cells(i, 1).Value2
        k = 2
        For j = 1 To 8
            Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
        Next
    End If
Next


End Sub

因此，函数ChkSheet将检查工作表是否存在，您不需要创建它们，程序测试将遵循原始数据工作表中的所有项目，并将复制到每个工作表的最后一行

请，即使是一个新手，谷歌，阅读，获取一些信息，当你堆积起来，寻求帮助。本论坛不是为了不劳而获地给出解决方案。

大家早上好

大卫，非常感谢你的帮助。我真的不想让你认为我是在试图让别人给我答案，在问这个问题之前我尝试了其他一些事情，但我忽略了展示我工作的任何证据。菜鸟的错误，我为此道歉

在网上做了更多的研究之后，在一位经验丰富的同事的帮助下，我使用Advanced filter获得了下面的代码，它非常适合我的需要

我想我会在这里分享它，以防将来对其他人有用

    Option Explicit

Dim RawDataCol As String
Dim ListCol As String
Dim AdvRng As String
Dim RawDataRng As String
Dim SiteAbrRng As String
Dim ShiftCols As String
Private Sub SetParameters()

'Cell Address where RawData is pasted to each of the site sheets
    RawDataCol = "A2"

'Column where the Unique List is cleared and pasted
    ListCol = "L"

'Advanced Filter Range
    AdvRng = "A1:K2"

'Pasted Raw Data Columns on each sheet
    RawDataRng = "A2:K"

'Site Abr gets pasted to the address during loop
    SiteAbrRng = "A2"

'Range that gets deleted after pasting Raw Data to each sheet
    ShiftCols = "A2:K2"

End Sub
Sub CopyDataToSheets()

On Error GoTo ErrorHandler

AppSettings (True)

Dim StartTime As Double
Dim SecondsElapsed As Double

    StartTime = Timer

Dim wbk As Workbook
Dim sht_RawData As Worksheet, sht_target As Worksheet, sht_AdvancedFilter As Worksheet, sht_TurbineData As Worksheet
Dim tbl_RawData As ListObject
Dim LastRow1 As Long, LastRow2 As Long, UniqueListCount As Long
Dim MyArr As Variant
Dim ArrTest As Boolean
Dim x As Long, AdvRowNo As Long

Set wbk = ThisWorkbook

SetParameters

Set sht_RawData = wbk.Worksheets("Raw Data")
Set sht_AdvancedFilter = wbk.Worksheets("Advanced Filter")
Set sht_TurbineData = wbk.Worksheets("Turbine Data")

Set tbl_RawData = sht_RawData.ListObjects("_00")

'clear unqie list of SiteAbr
With sht_TurbineData

    LastRow1 = .Cells(Rows.Count, 12).End(xlUp).Row

    If LastRow1 > 1 Then
        'sht_TurbineData.Range("L1:L" & LastRow1).ClearContents
        sht_TurbineData.Range(ListCol & 1 & ":" & ListCol & LastRow1).ClearContents
    End If

End With

'Copy Unqiue list of SiteAbr to Turbie Data Sheet
tbl_RawData.Range.Columns(1).AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=sht_TurbineData.Range(ListCol & 1), _
    Unique:=True

    LastRow1 = sht_TurbineData.Cells(Rows.Count, sht_TurbineData.Range(ListCol & 1).Column).End(xlUp).Row

    'Sort Unique List
    sht_TurbineData.Range("L1:L" & LastRow1).Sort _
    Key1:=sht_TurbineData.Range("L1"), _
    Order1:=xlAscending, _
    Header:=xlYes

'Load unique site Abr to array
With sht_TurbineData

    'MyArr = Application.Transpose(.Range("L2:L" & LastRow1))
    MyArr = Application.Transpose(.Range(ListCol & 2 & ":" & ListCol & LastRow1))

    UniqueListCount = LastRow1 - 1

End With

'Test Array conditions for 0 items or 1 item

ArrTest = IsArray(MyArr)

If UniqueListCount = 1 Then
    MyArr = Array(MyArr)

ElseIf UniqueListCount = 0 Then
    GoTo ExitSub

End If

    For x = LBound(MyArr) To UBound(MyArr)

        Set sht_target = wbk.Worksheets(MyArr(x))

                With sht_target

                    'Find the last non blank row of the target paste sheet
                    LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row

                    'Clear contents if the Last Row is not the header row
                    If LastRow2 > 1 Then
                        .Range(RawDataRng & LastRow2).ClearContents
                    End If

                    sht_AdvancedFilter.Range(SiteAbrRng) = MyArr(x)

                    'Filter Source Data and Copy to Target Sheet
                    tbl_RawData.Range.AdvancedFilter _
                        Action:=xlFilterCopy, _
                        CriteriaRange:=sht_AdvancedFilter.Range(AdvRng), _
                        CopyToRange:=.Range(RawDataCol), _
                        Unique:=False

                    'Remove the first row as this contains the headers
                    .Range(ShiftCols).Delete xlShiftUp

                End With

    Next x

ExitSub:
    SecondsElapsed = Round(Timer - StartTime, 3)

    AppSettings (False)

    'Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation



Exit Sub
ErrorHandler:
    MsgBox (Err.Number & vbNewLine & Err.Description)
    GoTo ExitSub

End Sub
Sub ClearAllSheets()

Dim tbl_SiteList As ListObject
Dim wbk As Workbook
Dim sht_target As Worksheet, sht_TurbineData As Worksheet
Dim MyArray As Variant
Dim x As Long, LastRow As Long

Set wbk = ThisWorkbook
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_SiteList = sht_TurbineData.ListObjects("SiteList")

SetParameters

MyArray = Application.Transpose(tbl_SiteList.DataBodyRange)

For x = LBound(MyArray) To UBound(MyArray)

    Set sht_target = wbk.Worksheets(MyArray(x))

        LastRow = sht_target.Cells(Rows.Count, 1).End(xlUp).Row

        If LastRow > 1 Then
            sht_target.Range("A2:K" & LastRow).ClearContents
        End If

Next x

End Sub
Private Sub AppSettings(Opt As Boolean)

If Opt = True Then

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

ElseIf Opt = False Then

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End If

End Sub

再次感谢所有回答的人，尤其是你，大卫。虽然我只使用了您提供的基本原则，但帮助我了解需要做什么才能将数据复制到正确的表格中是非常有用的

非常感谢,，

---

MrChrisP

我正在尝试编写一个宏-这是一个好的开始。请把你迄今为止的努力公布出来。你可以在网上找到这个问题的例子。步骤是1创建唯一站点列表2使用自动筛选循环提取每个站点的相关记录3将筛选的记录复制到新工作表。欢迎使用SO。请看。另外，请查看，以及更多关于