Макрос Vba Excel копирует ячейки на другой лист и в разные позиции

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

Предполагая, что таблица данных называется 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

Answer 2

Вы можете попробовать что-то вроде этого.

Вы заполняете массив номерами элементов и именами листов.

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