宏移動列到新的工作表只能移動最後一列

Question

我想用頭名稱選定列移動到一個新的頁面粘貼到連續列開始列A

我的宏僅在移動的最後一列

由於

Sub MoveColumnsToNewSheet() 
Dim ar As Variant 
Dim i As Variant 
Dim j As Long 
Dim LR As Long 

Sheets(1).Select 

    ar = Array("user name", "Label")  ' Find column to copy 

LR = Range("A" & Rows.Count).End(xlUp).Row 
On Error Resume Next 
For i = LBound(ar) To UBound(ar) 
    j = Rows(1).Find(ar(i), Rows(1).Cells(Rows(1).Cells.Count), , xlWhole, xlByRows).Column 

     Range(Cells(1, j), Cells(LR, j)).Copy _ 
     Destination:=Worksheets(2).Columns(i) 
Next i 
On Error GoTo 0 

End Sub 

Answer 1

的主要問題是一個Variant陣列的LBound將是0，因此將Columns(i)在第一循環失敗。我認爲，不是「只移動最後一列」，而是不移動第一列 - 只有兩列的微妙區別。

如果您的On Error語句跨越較少的代碼，這將更容易發現。您只需要它用於Find聲明。

另外請注意，你需要重置每次j爲0，然後檢查是否有什麼東西在通過檢測發現，如果它仍然是0。

最後，請所有符合條件的範圍，行等，具有工作表的名稱。我這樣做，在這裏使用With聲明，使其少重複：

Sub MoveColumnsToNewSheet() 
Dim wsSource As Excel.Worksheet 
Dim wsTarget As Excel.Worksheet 
Dim ar As Variant 
Dim i As Variant 
Dim j As Long 
Dim LR As Long 

Set wsSource = ThisWorkbook.Worksheets(1) 
Set wsTarget = ThisWorkbook.Worksheets(2) 
ar = Array("user name", "Label")  ' Find column to copy 

With wsSource 
    LR = .Range("A" & .Rows.Count).End(xlUp).Row 
    For i = LBound(ar) To UBound(ar) 
     On Error Resume Next 
     j = 0 
     j = .Rows(1).Find(ar(i), .Rows(1).Cells(.Rows(1).Cells.Count), , xlWhole, xlByRows).Column 
     On Error GoTo 0 
     If j <> 0 Then 
      .Range(.Cells(1, j), .Cells(LR, j)).Copy _ 
        Destination:=wsTarget.Columns(i + 1) 
     End If 
    Next i 
End With 

最後，終於，我會鼓勵更多有意義的變量名比ar。當這段代碼增長並且時間流逝時，你會說「這是什麼？！」