VBA宏select复制循环

Question

我在处理宏时遇到了一些问题。在这里查看数据和 VBA 宏：https://ufile.io/339xz

我的 excel 看起来是这样的：

我需要它看起来像这样：

系统是这样的： 1) 对于每个 'husstr' 一个新行，每个 houshold_order 一个字段（对于 4 人的家庭最多 4 个字段） 2) household_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

VBA宏select复制循环

VBA macro select copy loop

excel

vba

for-loop

copy-paste

do-while