Question

我必须在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

Answer 1

您可以尝试这样的事情。

您在阵列中填充了项目编号和图纸名称。

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

Answer 2

假设数据表名为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

Vba Excel宏复制单元格在另一个工作表上的不同位置

2 个答案: