Search code examples
excelvbafor-loopcopy-pastedo-while

VBA macro select copy loop

I have some trouble with a macro I'm working on. See here for the data and the VBA macros: https://ufile.io/339xz

My excel looks this: Is now

I need it to look like this: Should be

The system goes like this: 1) for each 'husstr' a new line is made with a field for each houshold_order (fx a max of 4 fields for a household of a size 4) 2) the corresponding 'stilling i husstanden' for the household_order is moved to its place (eg. household order 1 in 'husstr' 1 goes to place 'stilling nr. 1')

The macro i've made works only on one household at a time, so I though I've would make a loop around it, but I cant seem to make it right.

Sub stack() moves the first three instances from husstr nr. 1 to the correct places (stilling nr. 1, stilling nr. 2 and stilling nr.3). That works perfectly! So fine.

    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

My trouble starts when I want to loop through the different 'husstr'-types. I've tried to solve it like this for the full dataset (contains 300K lines in all). I've made to sets of loops.

The first sub i the bigger loop: 

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

And the next sub is the smaller loop:

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

It doesn't look like I can upload the excel here, so I've posted it here: https://ufile.io/339xz

Solution

  • This is untested, so please work on a copy of your file:

    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