Question

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

我正在尝试编写一个宏，该宏将特定站点的数据复制并粘贴到文件中它们各自的工作表中。我熟悉此基本概念，但是我在为需要指定的范围而苦苦挣扎。

因此，基本上，我需要宏沿工作表的原始数据列A向下移动，并标识站点名称（列A中的值）与工作表名称之一匹配的任何行。然后，应使用该站点名称将行从A复制到H，然后粘贴到A到H的相应站点表中。

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

示例图片可能会有助于更好地说明问题：

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

但是，我非常热衷于学习，非常感谢您提供的任何指导。

Answer 1

欢迎！

尝试这个

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将检查工作表是否存在（您无需创建工作表），并且过程测试将跟踪“原始数据”工作表中的所有项目，并将其复制到上次使用的工作表中每张纸的一行。

而且，即使是对于新手Google来说，也请阅读并获取一些信息，当您堆积如山时，请寻求帮助。该论坛不是为了毫不费力地提供解决方案。

Answer 2

早上好，

大卫，非常感谢您在此方面的帮助。我真的不希望您认为我试图让别人给我答案，并且在提出问题之前我尝试了其他一些方法，但是我却没有提供任何有关我工作的证据。新秀错误，对此我深表歉意。

已经在网上做了更多的研究，并且在经验丰富的同事的大力支持下，我使用了高级过滤器获得了以下代码，该代码非常适合我的需求。

我想在这里分享一下，以防将来对其他人有用。

    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

将数据从一张工作表复制并粘贴到多个范围匹配工作表名称的地方

2 个答案: