如果滿足條件，則將行數據從特定列復制到另一張工作表

Question

我需要查看第2行AU列中的值（從標題行之后立即開始），如果不為空，則將數據從該行中的特定列復制到另一張紙上。

例如，假設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