VBA宏选择复制循环

Question

我正在处理的宏有些麻烦。 有关数据和VBA宏，请参见此处：https://ufile.io/339xz

我的excel看起来是这样的：

我需要它看起来像这样：

系统如下所示： 1）对于每个“麻烦的人”，每行houshold_order都会创建一个新行（对于大小为4的家庭，最多可容纳4个字段） 2）将family_order的相应“静止i husstanden”移到其位置（例如“ husstr” 1中的家庭命令1移至“ stilling nr。1”位置）

我制作的宏一次只能在一个家庭中使用，因此尽管我会对其进行循环，但是我似乎无法正确执行。

Sub stack（）从husstr nr中移出前三个实例。 1到正确的位置（静止1，静止2和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