Vba에서 For 루프의 변수 증가?

Question

# This is the input table for which I want to perform some action는 #

Public Sub mac() 

    Dim RangeOfChild As Range 

For i = 1 To 10000 
ActiveCell.Range("A" & i).Activate 

Dim DirArray As Variant 

Dim temp As Variant 

Set RangeOfChild = Range(ActiveCell.Offset(0, 1),ActiveCell.End(xlToRight)) 
childCount = RangeOfChild.count 
temp = ActiveCell.Value 
ActiveCell = Null 

DirArray = RangeOfChild.Value 
RangeOfChild.ClearContents 

ActiveCell.EntireRow.Resize(childCount - 1).Insert Shift:=xlDown 
ActiveCell.Value = temp 

Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(RangeOfChild.count - 1, 1)) = Application.Transpose(Array(DirArray)) 

i = i + (childCount) 

Next i 

End Sub 

나는 아래 이미지

enter image description here

하지만 루프에 대한 기록은 남아 있지, 행의 두 가지로 작업을하고있는에 유사한 출력을 원하는 누군가가 이것으로 나를 도울 수 있다면 큰 도움이 될 것입니다.

Answer 1

이 작업은 입력 데이터가 들어있는 워크 시트 ("SheetInput")와 형식이 지정된 출력을받는 워크 시트 ("SheetOutput")의 두 가지 워크 시트를 사용하여 수행했습니다.

Option Explicit 

Public Sub mac() 
Dim wsData As Worksheet, wsOutput As Worksheet 
Dim rngInput As Range, RangeOfChild As Range, rngOutput As Range 
Dim childCount As Long 

    Set wsData = ThisWorkbook.Worksheets("SheetInput") 
    Set wsOutput = ThisWorkbook.Worksheets("SheetOutput") 
    Set rngInput = ThisWorkbook.Worksheets("SheetInput").Cells(1, 1) 
    Set rngOutput = ThisWorkbook.Worksheets("SheetOutput").Cells(1, 1) 

    While Not (IsEmpty(rngInput)) 
     Set RangeOfChild = Range(rngInput.Offset(0, 1), rngInput.End(xlToRight)) 
     childCount = RangeOfChild.Count 
     rngInput.Copy 
     rngOutput.PasteSpecial Paste:=xlPasteAll 
     RangeOfChild.Copy 
     rngOutput.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True 
     Set rngInput = rngInput.Offset(1, 0) 
     Set rngOutput = rngOutput.Offset(childCount, 0) 
    Wend 

End Sub 

Answer 2

활성화 방법이 좋지 않습니다. 변형 배열을 사용하십시오.

Sub test() 
    Dim rngDB As Range, rngCnt As Range 
    Dim rng As Range, rng2 As Range 
    Dim vCnt, vR() 
    Dim i As Integer, c As Integer, n As Long, s As Long 

    Set rngDB = Range("a1", Range("a" & Rows.Count).End(xlUp)) 
    For Each rng In rngDB 
     Set rngCnt = Range(rng.Offset(, 1), rng.End(xlToRight)) 
     s = n + 1 
     vCnt = rngCnt 
     c = rngCnt.Columns.Count 
     n = n + c 
     ReDim Preserve vR(1 To 2, 1 To n) 
     vR(1, s) = rng 
     For i = 1 To c 
      vR(2, s + i - 1) = vCnt(1, i) 
     Next i 
    Next rng 
    Sheets.Add 
    Range("a1").Resize(n, 2) = WorksheetFunction.Transpose(vR) 

End Sub