Sub a() Set ab = ThisWorkbook.Sheets(1).Range("a1:a" & ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row) i = 1 y = 1 ThisWorkbook.Sheets(3).UsedRange.Clear For Each aa In ab With ThisWorkbook.Sheets(3) .Range("a" & i).Value = aa .Range("b" & i).Value = ThisWorkbook.Sheets(1).Range("b" & y).Value .Range("c" & i).Value = ThisWorkbook.Sheets(1).Range("c" & y).Value .Range("d" & i).Value = ThisWorkbook.Sheets(1).Range("d" & y).Value End With
If a.Value = 2 Then i = i + 2 Else i = i + 1 End If y=y+1 Next aa End Sub
[/vba]
Как-то так надо только добавить 3 листик [vba]
Код
Sub a() Set ab = ThisWorkbook.Sheets(1).Range("a1:a" & ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row) i = 1 y = 1 ThisWorkbook.Sheets(3).UsedRange.Clear For Each aa In ab With ThisWorkbook.Sheets(3) .Range("a" & i).Value = aa .Range("b" & i).Value = ThisWorkbook.Sheets(1).Range("b" & y).Value .Range("c" & i).Value = ThisWorkbook.Sheets(1).Range("c" & y).Value .Range("d" & i).Value = ThisWorkbook.Sheets(1).Range("d" & y).Value End With
If a.Value = 2 Then i = i + 2 Else i = i + 1 End If y=y+1 Next aa End Sub
i = 1 Do While i < Cells(Rows.Count, 1).End(xlUp).Row If val(Cells(i, 1).Value) = 2 Then Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove i = i + 2 Else: i = i + 1 End If Loop
End Sub
[/vba]
dima_dan2012, какой листик? зачем? [vba]
Код
Sub test()
Dim i As Integer
i = 1 Do While i < Cells(Rows.Count, 1).End(xlUp).Row If val(Cells(i, 1).Value) = 2 Then Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove i = i + 2 Else: i = i + 1 End If Loop
dima_dan2012, способов "испортить данные" существует столько, что мы с Вами все не предусмотрим. Однако хранить устаревшие ненужные данные, да ещё в одной свалке с нужными и актуальными — ничуть не лучше. Запустите несколько раз Ваш макрос и посмотрите, что станет с размером файла и обозримостью результатов. А потом попытайтесь объяснить другому макросу, откуда именно ему брать данные.
dima_dan2012, способов "испортить данные" существует столько, что мы с Вами все не предусмотрим. Однако хранить устаревшие ненужные данные, да ещё в одной свалке с нужными и актуальными — ничуть не лучше. Запустите несколько раз Ваш макрос и посмотрите, что станет с размером файла и обозримостью результатов. А потом попытайтесь объяснить другому макросу, откуда именно ему брать данные.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Я уж не говорю о том, что непонятна религия, мешающая перенести сразу всё на новый лист и обрабатывать там: [vba]
Код
Sub test()
Dim i As Integer Dim Sht as String
Sht=ActiveSheet.Name Worksheets.Add After:=Worksheets(Sheets.Count) Worksheets(Sht).Cells.Copy Destination:=Cells i = 1 Do While i < Cells(Rows.Count, 1).End(xlUp).Row If val(Cells(i, 1).Value) = 2 Then Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove i = i + 2 Else: i = i + 1 End If Loop
End Sub
[/vba] И да:
Цитата
[vba]
Код
ThisWorkbook.Sheets(3).UsedRange.Clear
[/vba]
Очищать не Вами созданный лист, на котором могут быть данные (и о котором Вам вообще неизвестно, есть ли он) — это тоже не good path... И да, кто Вам сказал, что данные непременно находятся в книге с макросом?
Я уж не говорю о том, что непонятна религия, мешающая перенести сразу всё на новый лист и обрабатывать там: [vba]
Код
Sub test()
Dim i As Integer Dim Sht as String
Sht=ActiveSheet.Name Worksheets.Add After:=Worksheets(Sheets.Count) Worksheets(Sht).Cells.Copy Destination:=Cells i = 1 Do While i < Cells(Rows.Count, 1).End(xlUp).Row If val(Cells(i, 1).Value) = 2 Then Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove i = i + 2 Else: i = i + 1 End If Loop
End Sub
[/vba] И да:
Цитата
[vba]
Код
ThisWorkbook.Sheets(3).UsedRange.Clear
[/vba]
Очищать не Вами созданный лист, на котором могут быть данные (и о котором Вам вообще неизвестно, есть ли он) — это тоже не good path... И да, кто Вам сказал, что данные непременно находятся в книге с макросом?StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Сообщение отредактировал StoTisteg - Воскресенье, 27.03.2016, 15:34