Vba Excel宏复制另一张图纸上不同位置的单元格

我必须在VBA中创建宏。我是这方面的新手，我不知道怎么做，但我有基本的编程技能。我必须将D列中的人的工资复制到一个不确定的数字（因为他们可以稍后将更多的人添加到列表中）。 如果在B列中找到数字，则必须复制对应人员的工资、代码和姓名，直到另一页的末尾：

它必须这样做：

这是我的代码：

Sub CopiarCeldas()

Dim i As Long, UltimaFila As Long, UltimaColumna As Long

Set Uno = Sheets("1")
Set Datos = Sheets("Datos")

lastRow = Uno.Cells(Rows.Count, "G").End(xlUp).Row

For i = 5 To lastRow
    'test if cell is empty
    If Uno.Range("B" & i).Value <> "" Then
        Datos.Range("D" & i - 1).Value = Uno.Range("G" & i).Value
        Datos.Range("L" & i - 1).Value = Uno.Range("L" & i).Value
    End If
Next i
      End sub

Sub-CopiarCeldas（）
Dim i长，UltimaFila长，UltimaColumna长
设置Uno=图纸（“1”）
设置Datos=图纸（“Datos”）
lastRow=Uno.Cells（Rows.Count，“G”）.End（xlUp）.Row
对于i=5到最后一行
'测试单元格是否为空
如果Uno.Range（“B”&i.Value”），则
Datos.Range（“D”和i-1）.Value=Uno.Range（“G”和i）.Value
Datos.Range（“L”和i-1）.Value=Uno.Range（“L”和i）.Value
如果结束
接下来我
端接头

您可以试试这样的方法

使用项目编号和图纸名称填充阵列

Sub CompareCopy()
Dim FirstSheet As Worksheet
Set FirstSheet = ActiveWorkbook.Worksheets("Sheet1") 'Define data sheet
Dim SecondSheet As Worksheet
Set SecondSheet = ActiveWorkbook.Worksheets("Sheet2") 'Define sheet to paste into
Dim lcol As Long
Dim lrow As Long
Dim lrowCompare As Long
Dim Val As String
Dim i As Long
Dim j As Long
Dim arr() 'Define the array

arr() = Array(1, 12, 13, 32, 42, 48, 162, 178, 216, 316, 321, 789, 987, 995, 996, 997, 999) 'Set the array with all the item numbers you want to compare

lcol = FirstSheet.Cells(5, Columns.Count).End(xlToLeft).Column 'Find last column in Row 5
lrow = FirstSheet.Cells(Rows.Count, 2).End(xlUp).Row 'Find last row in Sheet1, for column B
lrowCompare = SecondSheet.Cells(Rows.Count, 2).End(xlUp).Row 'Find last row in Sheet2 for Column B

For k = 4 To lcol                                'Loop from Column D to last Column
    For i = 11 To lrow                           'Loop through ID column in Sheet 1
        Val = FirstSheet.Cells(i, 2).Value       'Get Item Value in Sheet 1
        For Each arrayItem In arr                'Loop through each element in Array
            If arrayItem = Val Then              'If array item is equal to Val then
                SecondSheet.Cells(lrowCompare, 3).Value = arrayItem 'Print array item
                SecondSheet.Cells(lrowCompare, 1).Value = FirstSheet.Cells(5, k).Value 'Print number
                SecondSheet.Cells(lrowCompare, 2).Value = FirstSheet.Cells(6, k).Value 'Print name
                If FirstSheet.Cells(i, k).Value <> "" Then 'If cell value is blank then ignore otherwise copy value
                    SecondSheet.Cells(lrowCompare, 4).Value = FirstSheet.Cells(i, k).Value 'Copy value
                End If
                lrowCompare = lrowCompare + 1    'Add 1 to row
            End If
        Next arrayItem
    Next i
Next k
End Sub

子比较副本（）
将第一张图纸变暗为工作表
设置FirstSheet=Active工作簿。工作表（“Sheet1”）定义数据表
将第二张工作表设置为工作表
设置SecondSheet=Active工作簿。工作表（“Sheet2”）定义要粘贴到的工作表
暗淡的lcol尽可能长
暗淡的光线和长的一样
暗淡的LROW与长的相同
作为字符串的Dim Val
我想我会坚持多久
Dim j尽可能长
Dim arr（）'定义数组
arr（）=数组（1、12、13、32、42、48、162、178、216、316、321、789、987、995、996、997、999）'使用要比较的所有项目编号设置数组
lcol=FirstSheet.Cells（5，Columns.Count）.End（xlToLeft）.Column'查找第5行中的最后一列
lrow=FirstSheet.Cells（Rows.Count，2）。End（xlUp）。Row'查找Sheet1中B列的最后一行
lrowCompare=SecondSheet.Cells（Rows.Count，2）。End（xlUp）。Row“查找Sheet2中B列的最后一行
对于从D列到最后一列的k=4到lcol'循环
对于第1页中的i=11至lrow'循环通过ID列
Val=FirstSheet.Cells（i，2）.Value'获取表1中的项目值
对于arr'循环中的每个arrayItem，通过数组中的每个元素
如果arrayItem=Val，则“如果数组项等于Val，则
SecondSheet.Cells（lrowCompare，3）.Value=arrayItem'打印数组项
SecondSheet.Cells（lrowCompare，1）.Value=FirstSheet.Cells（5，k）.Value'打印编号
SecondSheet.Cells（lrowCompare，2）.Value=FirstSheet.Cells（6，k）.Value'打印名称
如果FirstSheet.Cells（i，k）.Value为“”，则“如果单元格值为空，则忽略其他复制值”
SecondSheet.Cells（lrowCompare，4）.Value=FirstSheet.Cells（i，k）.Value'复制值
如果结束
lrowCompare=lrowCompare+1'将1添加到行
如果结束
下一个阵列项目
接下来我
下一个k
端接头

假设数据表名为Sheet1，结果表名为Sheet2，您可以尝试：

Sub test()

    Dim n As Integer 'n will represent the column at which you find the first people
    n = 4
    Dim m As Integer 'm will represent the row on your Sheet2
    m = 2

    Worksheets("Sheet1").Activate

    ' Loop on the people's name
    Do While Not IsEmpty(Cells(6, n))
        ' Loop on items, 50 to be replaced by the row number of your last item
        For i = 11 To 50
            If Not IsEmpty(Cells(i, 2)) Then
                ' Report people main salary
                Sheets("Sheet1").Activate
                Cells(5, n).Select
                Selection.Copy
                Sheets("Sheet2").Select
                Cells(m, 2).Select
                ActiveSheet.Paste
                'Report people name
                Sheets("Sheet1").Activate
                Cells(6, n).Select
                Selection.Copy
                Sheets("Sheet2").Select
                Cells(m, 3).Select
                ActiveSheet.Paste
                ' Report item code
                Sheets("Sheet1").Activate
                Cells(i, 2).Select
                Selection.Copy
                Sheets("Sheet2").Select
                Cells(m, 4).Select
                ActiveSheet.Paste
                'Report item value
                Sheets("Sheet1").Activate
                Cells(i, n).Select
                Selection.Copy
                Sheets("Sheet2").Select
                Cells(m, 5).Select
                ActiveSheet.Paste
                m = m + 1 'Iterate row counter
            End If
        Worksheets("Sheet1").Activate
        ' Next item for the same people
        Next i
    ' Next people
    n = n + 1
    Loop
    Worksheets("Sheet2").Activate
End Sub

---

欢迎来到堆栈溢出。请注意，因为这不是免费的代码编写服务，所以有必要显示您迄今为止所做的尝试以及您遇到的问题或错误（通过显示代码），或者至少显示您所做的研究和努力。否则它只是要求我们为你做所有的工作。阅读可以帮助你改进你的问题。