VBA堆棧到前兩個下面的幾列

Question

我有幾個工作簿，其中包含大量的列（每次不同數量的列）和大量的行。我想將列範圍內的所有值複製到列A和列B中。值必須成對複製，並且可以包含空單元格，甚至是空行，這些行也必須複製。

現在我有以下數據集的結構：

A B  C  D  E  F ....... 
red cat black dog yellow fox ....... 
red cat white dog yellow fox ....... 
grey cat black dog yellow fox ....... 
.......................................... 

串聯後，我的數據必須是這樣的：

A  B  
red cat 
red cat 
grey cat 
black dog 
white dog 
black dog 
yellow fox 
yellow fox 
yellow fox 

我已經找到了計算器，它工作正常this post，但它不會保留我的數據的原始成對順序並跳過空單元格。我很難找出如何調整這個代碼來解決我的問題。

此外，我發現another solution和我一直試圖修改它，但我在第8行

這裏得到的消息「運行時錯誤1004」是我修改的方案：

Sub MoveColumnsUnderAB() 

Dim ws  As Worksheet 
Dim lr  As Long 
Dim lc  As Integer 

Set ws = ThisWorkbook.Worksheets("Sheet1") 

lc = ws.Range("XFD1").End(xlToLeft).column '' Find the last column 

While lc <> 2 '' stop once it hits Column B 

    lr = ws.Cells(1, lc).End(xlDown).Row '' Find the last row for this block of 2 
    ws.Range(ws.Cells(1, lc).Offset(, -1), ws.Cells(lr, lc)).Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1) 

    ws.Range(ws.Cells(1, lc).Offset(, -1), ws.Cells(lr, lc)).ClearContents '' Clear it out 
    lc = ws.Range("XFD1").End(xlToLeft).column '' Get the last column again for the While loop 
Wend 

End Sub 

我將不勝感激任何幫助。

Answer 1

該代碼有點低效，因爲我不在辦公室。它應該可以工作，但是如果有缺失的列，這將是有問題的，因爲配對和缺乏對其他列可能是什麼的知識。

Option Explicit 

Sub MoveColumnsUnderAB() 
Dim y, store, lc 
Dim ws As Worksheet 
Dim rng As Range 

Set ws = ThisWorkbook.Worksheets("Sheet2") 

lc = ws.Range("XFD1").End(xlToLeft).Column '' Find the last column 
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(1, lc)) 

For Each y In rng 

If y = "Attribute" Or y = "Category" Or IsEmpty(y.Offset(1, 0)) And y.Offset(1, 0).End(xlDown).Row > ws.Range("A1").SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row Then 
Else 
store = Left(y.Address, InStr(2, y.Address, "$") - 1) 
store = Right(store, InStr(1, y.Address, "$")) 
ws.Range(store & "2:" & store & ws.Range("A1").SpecialCells(xlCellTypeLastCell).Row).Select 
Range(Selection, Selection.Offset(0, 1)).Select 
Selection.Cut 
ws.Range("A" & ws.Range("A1").SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row).End(xlUp).Offset(1, 0).Select 
ActiveSheet.Paste 
End If 
Next y 
End Sub