Если условие выполнено, скопируйте данные строки из определенных столбцов на другой лист

Question

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

Например, предположим, что AU2 не пусто, затем скопируйте A2 в A2, D2 в B2, J2 в C2 и т. Д.

Вот где я сейчас нахожусь:

Sub copycolumns()

Dim lastrow As Long, erow As Long
lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
wb = ThisWorkbook
ws1 = wb.Sheets("Sheet Name")
ws2 = wb.Sheets("Sheet Name2")

For Each Cel In ws1.Range("AU2:AU" & lastrow)

    If IsEmpty(Cel.Value) Then

        For I = 2 To lastrow

            ws1.Cells(I, 2).Copy ws2.Cells(erow, 1)
            ws1.Cells(I, 4).Copy ws2.Cells(erow, 2)
            ws1.Cells(I, 6).Copy ws2.Cells(erow, 3)
            ws1.Cells(I, 7).Copy ws2.Cells(erow, 4)
            ws1.Cells(I, 8).Copy ws2.Cells(erow, 5)
            ws1.Cells(I, 10).Copy ws2.Cells(erow, 6)
            ws1.Cells(I, 11).Copy ws2.Cells(erow, 7)
            ws1.Cells(I, 12).Copy ws2.Cells(erow, 8)
            ws1.Cells(I, 16).Copy ws2.Cells(erow, 9)
            ws1.Cells(I, 20).Copy ws2.Cells(erow, 10)
            ws1.Cells(I, 26).Copy ws2.Cells(erow, 11)
            ws1.Cells(I, 27).Copy ws2.Cells(erow, 12)
            ws1.Cells(I, 28).Copy ws2.Cells(erow, 13)
            ws1.Cells(I, 29).Copy ws2.Cells(erow, 14)
            ws1.Cells(I, 36).Copy ws2.Cells(erow, 15)
            ws1.Cells(I, 37).Copy ws2.Cells(erow, 16)
            ws1.Cells(I, 45).Copy ws2.Cells(erow, 17)
            ws1.Cells(I, 55).Copy ws2.Cells(erow, 18)
            ws1.Cells(I, 59).Copy ws2.Cells(erow, 19)
            ws1.Cells(I, 63).Copy ws2.Cells(erow, 20)
            ws1.Cells(I, 47).Copy ws2.Cells(erow, 21)

            erow = erow + 1

        Next I

    End If

Next

'ws2.Columns().AutoFit

End Sub

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

Answer 1

Попробуйте это ниже:

Sub copycolumns()

Dim lastrow As Long, erow As Long

Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet Name")
Set ws2 = wb.Sheets("Sheet Name2")

lastrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1

For Each Cel In ws1.Range("AU2:AU" & lastrow)

    If Len(Cel.Value) > 0 Then

        For I = 2 To lastrow

            ws1.Cells(I, 2).Copy ws2.Cells(erow, 1)
            ws1.Cells(I, 4).Copy ws2.Cells(erow, 2)
            ws1.Cells(I, 6).Copy ws2.Cells(erow, 3)
            ws1.Cells(I, 7).Copy ws2.Cells(erow, 4)
            ws1.Cells(I, 8).Copy ws2.Cells(erow, 5)
            ws1.Cells(I, 10).Copy ws2.Cells(erow, 6)
            ws1.Cells(I, 11).Copy ws2.Cells(erow, 7)
            ws1.Cells(I, 12).Copy ws2.Cells(erow, 8)
            ws1.Cells(I, 16).Copy ws2.Cells(erow, 9)
            ws1.Cells(I, 20).Copy ws2.Cells(erow, 10)
            ws1.Cells(I, 26).Copy ws2.Cells(erow, 11)
            ws1.Cells(I, 27).Copy ws2.Cells(erow, 12)
            ws1.Cells(I, 28).Copy ws2.Cells(erow, 13)
            ws1.Cells(I, 29).Copy ws2.Cells(erow, 14)
            ws1.Cells(I, 36).Copy ws2.Cells(erow, 15)
            ws1.Cells(I, 37).Copy ws2.Cells(erow, 16)
            ws1.Cells(I, 45).Copy ws2.Cells(erow, 17)
            ws1.Cells(I, 55).Copy ws2.Cells(erow, 18)
            ws1.Cells(I, 59).Copy ws2.Cells(erow, 19)
            ws1.Cells(I, 63).Copy ws2.Cells(erow, 20)
            ws1.Cells(I, 47).Copy ws2.Cells(erow, 21)

            erow = erow + 1

        Next I

    End If

Next

'ws2.Columns().AutoFit

    End Sub

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

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