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

我在stackoverflow上找到了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

VBA在前两个下堆叠到多个列

1 个答案: