Требуется макрос VBA - циклическое копирование данных с одного листа на другой

Question

В прошлом году я сделал огромную электронную таблицу со всеми новейшими доступными данными по каждой стране в мире.Идея заключалась в том, чтобы я мог загрузить самые последние данные - скажем, таблицу данных, содержащую статистику населения из Всемирного банка, - и легко перенести их в свой основной лист.

Вот пример того, как это выглядело:

Чтобы извлечь данные из других электронных таблиц, я использовал длинные беспорядочные линии функций IF, такие как:

=IF(ISNUMBER(IFERROR(VLOOKUP($A3;Population!$A$3:$C$400;2;FALSE);"Not 
Found"));IFERROR(VLOOKUP($A3;Population!$A$3:$C$400;2;FALSE);"Not 
Found");"Not Found")&" 
("&IF(ISNUMBER(IFERROR(VLOOKUP($A3;Population!$A$3:$C$400;3;FALSE);"Not 
Found"));IFERROR(VLOOKUP($A3;Population!$A$3:$C$400;3;FALSE);"Not 
Found");"Not Found")&")"

Очевидно, что это не самый эффективный способ сделать это.Вот что мне нужно сделать для макроса:

1. Для первого сопоставления столбца A, содержащего все названия стран, на моем основном листе, с столбцом A в листе данных, содержащем страны, специфичные для этого набора данных..
2. Затем скопируйте и вставьте последние данные (непустая ячейка, крайняя справа) из таблицы данных на основной лист в соответствующих местах (т. Е. Уганда сопоставляется с Угандой).
3. Вставленные данные также должны содержать соответствующие годы в скобках (на рисунке все данные получены с 2016 года, но это не всегда так).

Я экспериментировал с некоторыми циклами, чтобы попытаться повторить вышеупомянутые IF-функции, но мне кажется, что ничего не работает.До сих пор мои попытки привели меня к этому:

Option Explicit

Sub test()

Dim data As Worksheet
Dim report As Worksheet
Dim finalrow As Integer
Dim finalcol As Integer
Dim rngMatch As Range
Dim i As Integer
Dim countryname As String

Set data = Ark2
Set report = Ark1

countryname = data.Range("A5").Value

report.Range("B2:CC300").ClearContents

data.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To finalrow
    If Cells(i, 1) = countryname Then
    Cells(i, 5).Copy
    report.Select
    Range("B300").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    data.Select
    End If

Next i

report.Select

End Sub

Здесь много недостатков, и это не приближается к решению моей проблемы.Может ли кто-нибудь указать мне правильное направление, что делать?

Спасибо, что уделили время.

Answer 1

РЕДАКТИРОВАТЬ - Как указал JvdV, вставка копий на самом деле не нужна, поэтому вместо этого я изменил код на report.Sheets[...].Value = data.Sheets[...].Value, что намного, намного быстрее.Еще раз спасибо, JvdV.

---

Итак, с помощью JvdV я смог собрать макрос, который прекрасно работает для меня.

Sub extract()

Dim RNG1 As Range, CL1 As Range
Dim LR1 As Long, LR2 As Long, LC As Long

Set report = Workbooks("Main.xlsm")
Set data = Workbooks("API_NE.EXP.GNFS.CD_DS2_en_excel_v2_9944773.xls")

report.Sheets("Report").Activate
data.Sheets("Data").Activate

LR1 = report.Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row
LR2 = data.Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
RC2 = report.Sheets("Report").Cells(LR1, Columns.Count).End(xlToLeft).Column + 1
RC3 = RC2 + 1

Set RNG1 = data.Sheets("Data").Range(Cells(1, 1), Cells(LR2, 1))
report.Sheets("Report").Cells(1, RC2).Value = data.Sheets("Data").Cells(5, 3).Value
report.Sheets("Report").Cells(1, RC3).Value = "Year"

For X = 2 To LR1
    With RNG1
        Set CL1 = .Find(What:=report.Sheets("Report").Cells(X, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not CL1 Is Nothing Then
            LC1 = data.Sheets("Data").Cells(CL1.Row, Columns.Count).End(xlToLeft).Column
            If IsNumeric(data.Sheets("Data").Cells(CL1.Row, LC1)) Then
                report.Sheets("Report").Cells(LR1, RC2).End(xlUp).Offset(1, 0).Value = data.Sheets("Data").Cells(CL1.Row, LC1).Value
            Else
                report.Sheets("Report").Cells(LR1, RC2).End(xlUp).Offset(1, 0).Value = "N/A"
            End If

            If IsNumeric(data.Sheets("Data").Cells(CL1.Row, LC1)) Then
                report.Sheets("Report").Cells(LR1, RC3).End(xlUp).Offset(1, 0).Value = data.Sheets("Data").Cells(4, LC1).Value
            Else
                report.Sheets("Report").Cells(LR1, RC3).End(xlUp).Offset(1, 0).Value = "N/A"
            End If


        End If
    End With
Next X

report.Sheets("Report").Activate

With Worksheets("Report").Columns(RC2)
    .NumberFormat = "0.00"
    .Value = .Value
End With

With Worksheets("Report").Columns(RC3)
    .NumberFormat = "0"
    .Value = .Value
End With

End Sub

Этот макроспозволяет извлекать последние данные из временных рядов, а также соответствующий год точки данных.В этом специфическом макросе вы можете дублировать данные по любой стране из любой таблицы, предоставленной Всемирным банком.Все, что вам нужно сделать, это:

1. подключить имя вашей рабочей книги (например, «Main.xlsm»), а также имя рабочей книги из Всемирного банка (например, «API_NE»)..EXP.GNFS.CD_DS2_en_excel_v2_9944773.xls ")
2. Назовите страны, которые вас интересуют, в столбце A собственной рабочей книги.
3. Пусть макрос запустится
4. Подключите новыйРабочая тетрадь от Всемирного банка
5. Пусть макрос запустится снова
6. и т. д.

Макрос не будет перезаписывать предыдущие данные, а скорее будет дублировать точки данных и выборочные годы всамые правые столбцы.Пример макроса в действии можно увидеть ниже.

Пример макроса

Answer 2

вот цикл, который будет:

• Цикл по столбцу A в вашей главной книге (названия стран)
• Поиск этой страны в вашей книге данных
• Получает последний использованный столбец найденной строки (если найдено значение)

• Печатает значение в прямом окне, очевидно, вы должны настроить этот фрагмент кода

  Sub Test()
  
  Dim RNG1 As Range, CL1 As Range
  Dim LR1 As Long, LR2 As Long, LC As Long
  
  LR1 = Workbooks("MainWB").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  LR2 = Workbooks("DataWB").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  Workbooks("DataWB").Activate
  Set RNG1 = Workbooks("DataWB").Sheets(1).Range(Cells(1, 1), Cells(LR2, 1))
  
  For X = 3 To LR1
      With RNG1
          Set CL1 = .Find(What:=Workbooks("MainWB").Sheets(1).Cells(X, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
          If Not CL1 Is Nothing Then
              LC = Workbooks("DataWB").Sheets(1).Cells(CL1.Row, Columns.Count).End(xlToLeft) + 1
              Debug.Print Workbooks("DataWB").Sheets(1).Cells(CL1.Row, LC).Value 'Do something else with this value obviously
          End If
      End With
  Next X
  
  Workbooks("MainWB").activate
  End Sub
  

Вам, очевидно, нужно настроить все переменные и имена в соответствии с вашими потребностями.Надеюсь, вы найдете полезные кусочки.