Страницы: 1
RSS
Перенос вертикально горизонтально расположенных данных (с различным числом строк)
 
Доброго времени суток.

Помогите, пожалуйста, решить проблемку. Необходимо горизонтально расположенные данные перенести вертикально. Как-то так:
А |В | 1 | 2 | 3| 4 | 5 | 6  | 7 | 8 |
С |D |1| 2| 3| 4 | 6 | 7 | 8 | 9 | 10 | 11| 12 | 13 |
преобразить в такой вид:
A | В| 1 | 2 |
A| В | 3 | 4 |
………….
C|D | 1| 2  |
C|D | 3 | 4  |
C|D | 5 | 6  |
……………
Количество ячеек в каждой строке различное, у куриц 16 дат, у петухов 26 дат.
 
Код
Sub iChicken()
Dim i As Long
Dim j As Long
Dim iLR As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
 iLR = Range("B1").End(xlDown).Row
   Range("A15:D" & iLastRow).ClearContents
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
   For i = 2 To iLR
     If Cells(i, "C") = "Курицы" Then
       For j = 6 To 21 Step 2
         Cells(iLastRow, "A") = Cells(i, "A")
         Cells(iLastRow, "B") = Cells(i, "C")
         Cells(iLastRow, "C") = Cells(i, j)
         Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
     Else
       For j = 6 To 31 Step 2
         Cells(iLastRow, "A") = Cells(i, "A")
         Cells(iLastRow, "B") = Cells(i, "C")
         Cells(iLastRow, "C") = Cells(i, j)
         Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
     End If
   Next
End Sub
 
Спасибо. Работает !!!
 
Цитата
написал:
 Range("A15:D" & iLastRow).ClearContents
Добрый вечер. Можно сделать, так чтобы вручную можно было  определить область выгрузки и выгрузка была бы на отдельном листе (таблица на много больше, чем вложеная).  
Изменено: MVMM - 12.01.2022 07:41:09
 
Евгений Алехин, здравствуйте
Не уверен, но похоже, что вам нужен редизайнер (покруче или попроще)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Выделите область. В примере это область "A2:AE5"
Запустите макрос.
Код
Sub Cocks_And_Chickens()
    Const FIRST_DATA_COLUMN = 6

    Dim rs As Range
    On Error Resume Next
    Set rs = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rs Is Nothing Then Exit Sub
    If rs.Cells.Count = 1 Then Exit Sub
    Dim arrIn As Variant
    Dim arrOu As Variant
    Dim yOu As Long
    Dim yIn As Long
    Dim xIn As Integer
    
    arrIn = rs.Areas(1)
    If IsEmpty(arrIn) Then Exit Sub
    
    yIn = UBound(arrIn, 1)
    xIn = UBound(arrIn, 2)
    If xIn < FIRST_DATA_COLUMN Then Exit Sub
    yOu = (xIn - FIRST_DATA_COLUMN) \ 2 + 1
    yOu = yOu * yIn
    ReDim arrOu(1 To yOu, 1 To 4)
    
    yOu = 0
    For yIn = 1 To UBound(arrIn, 1)
        For xIn = FIRST_DATA_COLUMN To UBound(arrIn, 2) - 1 Step 2
            If (arrIn(yIn, xIn + 0) <> "") Or (arrIn(yIn, xIn + 1) <> "") Then
                yOu = yOu + 1
                arrOu(yOu, 1) = arrIn(yIn, 1)
                arrOu(yOu, 2) = arrIn(yIn, 3)
                
                If arrIn(yIn, xIn + 0) <> "" Then arrOu(yOu, 3) = arrIn(yIn, xIn + 0)
                If arrIn(yIn, xIn + 1) <> "" Then arrOu(yOu, 4) = arrIn(yIn, xIn + 1)
            End If
        Next
    Next
    If yOu > 0 Then
        With Workbooks.Add(1)
            With .Sheets(1).Cells(1, 1).Resize(yOu, UBound(arrOu, 2))
                .ColumnWidth = 10
                .NumberFormat = "@"
                .Value = arrOu
            End With
            .Saved = True
        End With
    End If
End Sub
 
MVMM, а зачем
Цитата
вручную можно было  определить область выгрузки
Добавьте в книгу Лист1
Код
Sub iChicken_1()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iLR As Long
Dim iLastRow As Long
 With Worksheets("Лист1")
   .Cells.Clear
   iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   iLR = Range("B1").End(xlDown).Row
   For i = 2 To iLR
     If Cells(i, "C") = "Курицы" Then
       n = 21
     Else
       n = 31
     End If
       For j = 6 To n Step 2
         .Cells(iLastRow, "A") = Cells(i, "A")
         .Cells(iLastRow, "B") = Cells(i, "C")
         .Cells(iLastRow, "C") = Cells(i, j)
         .Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
   Next
   .Range("A2:D" & iLastRow - 1).Borders.Weight = xlThin
   .Activate
 End With
End Sub
Изменено: Kuzmich - 12.01.2022 11:13:03
 
Цитата
Jack Famous написал: Не уверен, но похоже, что вам нужен редизайнер (покруче или попроще)
Добрый день. Спасибо "Сложный" Редизайнер подходит на 99 % (останется только удалить пустые строчки).

МатросНаЗебре, макрос работает и выполняет возложенные функции на 100%.
Kuzmich, макрос работает и выполняет возложенные функции на 99%  (останется только удалить  пустые строчки).

Большое спасибо! Теперь у меня есть Три рабочих Макроса

P.S. До того как написать на данном фроме потратил много времени на поиск в интернете, но сложный  Редизайнер не разу не попался (простой редизайнер и различные надстройки (схожие с функционалом с простым) попадались множества раз.
Страницы: 1
Наверх