첫 번째 두 개의 열 아래에 여러 개의 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 ....... 
.......................................... 

하는 연결 후 내 데이터는 다음과 같이해야합니다 : 지금은 데이터 세트의 구조 다음 한

내가 잘 작동 유래에 this post을 발견

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

하지만, 내 데이터의 원래 쌍을 이루는 순서를 유지하지 않고 빈 셀을 건너 뜁니다. 이 코드를 내 문제에 맞게 조정하는 방법을 찾는 것이 어려웠습니다.

게다가, 나는 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