VBA宏选择复制循环

Question

我正在处理的宏遇到了一些问题。 有关数据和 VBA 宏，请参见此处：https://ufile.io/339xz

我的 excel 看起来是这样的：

我需要它看起来像这样：

系统是这样的： 1) 对于每个“husstr”，每个 houshold_order 都有一个字段组成一个新行（对于 4 号家庭来说，最多 4 个字段） 2) home_order 对应的 'stilling i husstanden' 被移动到它的位置（例如，'husstr' 1 中的家庭订单 1 到位置 'stilling nr. 1'）

我制作的宏一次只适用于一个家庭，所以我虽然会围绕它制作一个循环，但我似乎无法让它正确。

Sub stack() 从 husstr nr 中移动前三个实例。 1 到正确的位置（stilling nr. 1、stilling nr. 2 和 Stilling nr.3）。这完美！太好了。

    Sub stack()
Dim i As Integer
i = 2

Dim placering As Integer
placering = 6

Dim maxloop As Integer
maxloop = Cells(i, 3).Value + 1

For i = 2 To maxloop

    Cells(i, 2).Select
    Selection.Copy

    Cells(2, placering).Select
    ActiveSheet.Paste

    placering = placering + 1
Next i
End Sub

当我想遍历不同的“husstr”类型时，我的麻烦就开始了。 我试图为完整的数据集（总共包含 300K 行）解决这个问题。我已经制作了几组循环。

第一个子是更大的循环：

Sub stilling_loop()
Dim k As Integer
k = 2

Dim i As Integer
i = 2

Dim checkhusst As Integer
checkhusst = 1

Do While i < 50
    If Cells(i, 1).Value = checkhusst Then Call fejl
    checkhusst = checkhusst + 1
    k = k + Cells(k, 3).Value
    i = k

Loop
End Sub

下一个子是较小的循环：

Sub fejl()
Dim o As Integer
o = 2

Dim placering As Integer
placering = 6

Dim maxloop As Integer
maxloop = Cells(o, 3).Value + 1

Dim række As Interior
rakke = 2

For i = 2 To maxloop

    Cells(i, 2).Select
    Selection.Copy

    Cells(rakke, placering).Select
    ActiveSheet.Paste

    placering = placering + 1
Next i

placering = 6
i = i + Cells(o, 3).Value
rakke = rakke + 1
o = o + Cells(o, 3).Value

End Sub

这里好像不能上传excel，所以贴在这里： https://ufile.io/339xz

Answer 1

这是未经测试的，因此请处理您的文件副本：

Dim i As Long
Dim j As Long

For i = 2 to ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    If Range("A" & i).value <> Range("A" & i - 1).value then
        j = i
        Range("E" & i).Value = Range("B" & i).value
    Else
        Range("E" & j).Offset(0, i - j).Value = Range("B" & i).Value
    End if
Next i