VBA макрос выбора копирования цикла - PullRequest
Новая
       43

VBA макрос выбора копирования цикла

0 голосов
/ 25 октября 2018

У меня проблемы с макросом, над которым я работаю.Смотрите здесь данные и макросы VBA: https://ufile.io/339xz

Мой Excel выглядит так: Is now

Мне нужно, чтобы это выглядело так: Should be

Система работает следующим образом: 1) для каждого 'husstr' создается новая строка с полем для каждого houshold_order (например, максимум 4 поля для домохозяйства с размером 4).) 2) соответствующий 'stilling i husstanden' для домашнего_заказа перемещен на свое место (например, заказ домашнего хозяйства 1 в 'husstr' 1 переходит на место 'неподвижный номер 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

Не похоже, что я могу загрузитьПревосходство здесь, поэтому я разместил его здесь: https://ufile.io/339xz

1 Ответ

0 голосов
/ 25 октября 2018

Это не проверено, поэтому, пожалуйста, поработайте над копией вашего файла: 

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
...