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

但是写for循环只对两行进行操作，而不是剩下的行。如果有人可以帮我解决这个问题，那将是一个很大的帮助。

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

在Vba中增加For循环中的变量？

2 个答案: