2017-10-07 81 views
0

This is the input table for which I want to perform some action在Vba中增加For循環中的變量?

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

但for循環寫只完成操作,以兩排中,沒有剩餘,如果有人能幫助我,這將是一個很大的幫助。

+0

變化'ActiveCell.Range( 「A」 &ⅰ).Activate'到'範圍( 「A」 &ⅰ).Activate'和改變'I = I +(childCount)''到I = I + childCount - 1'(但是,這是一種不好的做事方式!) – YowE3K

回答

0

我通過使用兩個工作表完成了此任務:包含輸入數據和工作表(「SheetOutput」)的工作表(「SheetInput」),它接收格式化的輸出。

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 
0

激活方法不好。使用變體數組。

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