Уважаемые программисты, можно ли к Вам обратиться помочь доработать код?
С листа "details" копируем 2 столбца, потом еще 10, но помещаем их в новый лист через 1 (начиная с 3-го столбца-2 мы уже скопировали). Файл прилагаю.
На листе2 показано, как это должно выглядеть.
С листа "details" копируем 2 столбца, потом еще 10, но помещаем их в новый лист через 1 (начиная с 3-го столбца-2 мы уже скопировали). Файл прилагаю.
| Код |
|---|
Private Sub Worksheet_Activate()
Dim i As Long, j As Long, lrow As Long
Dim UserRange As Range
Dim iCells As Range
lrow = UserRange.Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("details").Range("B2").CurrentRegion
Set UserRange = Sheets("details").Union(.Columns("B"), .Columns("C"), .Range("R2:AB2"))
Union(.Columns("B"), .Columns("C")).Copy Sheets("Лист1").Range("B1")
'Range("R2:AB2").Copy Cells(RowsCount, "D").End(xlUp).Offset(2)
'значения вставляются каждый раз в следующую строку
End With
'Range("R2:AB2" & lrow).Copy Sheets("Лист1").Range("D2")
For Each iCells In Sheets("details").Range("R2" & lrow & ":AB2" & lrow)
If Worksheets("details").Cells(iCells, "R2").Value > 0 Then
For W = 3 To lrow
If IsEmpty(Cells(W, 1)) Then
For j = 1 To 10 'так как нужно скопировать с R2 по AB2 -10- столбцов
Do
Cells(W, j) = Worksheets("details").Cells(iCells, j)
j = 2 * j + 1
iCells = iCells + 1
Loop Until Columns(j).Find(What:="*") Is Nothing Or j = Columns.Count
'.PasteSpecial xlPasteAll
.PasteSpecial xlPasteColumnWidths ' ширина столбца'
.PasteSpecial xlPasteValues ' значения'
.PasteSpecial xlPasteFormats ' форматы'
Next j
Exit For
End If
Next W
End If
Next iCells
'End With
Application.CutCopyMode = False
End Sub
|
На листе2 показано, как это должно выглядеть.
Изменено: - 29.12.2018 10:05:27
. Я на этот код потратила недели 2, и он еще не работает...
Может, быстрее будет?..
