Скопируйте и вставьте данные с одного листа на несколько, где диапазон соответствует именам листов

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