需要 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

这是一个循环：

• 遍历主工作簿中的 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
  

您显然需要根据需要调整所有变量和名称。希望您会发现有用的点点滴滴。

Answer 2

编辑 - 正如 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. 等

宏不会覆盖以前的数据，而是在最右边的列中复制数据点和样本年份。下面是一个正在运行的宏示例。

Example of the macro