Вопрос по Excel

Не верный (

Есть ещё варианты ?
 
Последнее редактирование модератором:
разбить на столбцы потом скопировать строку и вставить данные в виде столбца на др листе и аналогично со второй строкой
 
Sub whatever()
Dim WS As Excel.Worksheet
Set WS = ActiveWorkbook.ActiveSheet
Dim WS2 As Excel.Worksheet
Dim i As Long, j As Long, k As Long
With ActiveWorkbook
Set WS2 = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
End With
WS2.Name = "RESULT"
With WS.UsedRange
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
k = k + 1
WS2.Cells(k, 1) = .Cells(i, j)
Next
Next
End With
WS.Select
End Sub
 
А точнее, если 1 столбец в исходнике надо оставить:
Код:
Sub whatever()
  Dim WS As Excel.Worksheet
  Set WS = ActiveWorkbook.ActiveSheet
  Dim WS2 As Excel.Worksheet
  Dim i As Long, j As Long, k As Long
  With ActiveWorkbook
    Set WS2 = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
  End With
  WS2.Name = "RESULT"
  With WS.UsedRange
    For i = 1 To .Rows.Count
      For j = 2 To .Columns.Count
        k = k + 1
        WS2.Cells(k, 1) = .Cells(i, 1)
        WS2.Cells(k, 2) = .Cells(i, j)
      Next
    Next
  End With
  WS.Select
End Sub
Это если че ВБА. Надо на нужном листе нажать Alt+F11, даблклик слева на "ЭтаКнига", в правом окне закопипастить этот код ниже того, что там уже есть, поставить курсор куда-нибудь в середину этого кода и нажать F5)
 
Последнее редактирование:
Можно создать руками CSV файл и вставить разделители строк, после чего открыть с помощью EXCEL указав необходимый разделитель строк, и EXCEL сама разложит на строки
 
все гораздо проще... есть стандартное решение
Топикстартеру нужно не транспонирование. Транспонирование поворачивает данные (было 2 строки - станет 2 столбца), а тут надо 2 строки в 1 столбец, так что VBA выше поможет
 
Код:
Sub ReversePivotTable()
'   Before running this, make sure you have a summary table with column headers.
'   The output table will have three columns.
    Dim SummaryTable As Range, OutputRange As Range
    Dim OutRow As Long
    Dim r As Long, c As Long

    On Error Resume Next
    Set SummaryTable = ActiveCell.CurrentRegion
    If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
        MsgBox "Select a cell within the summary table.", vbCritical
        Exit Sub
    End If
    SummaryTable.Select
    Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)
'   Convert the range
    OutRow = 2
    Application.ScreenUpdating = False
    OutputRange.Range("A1:C3") = Array("Column1", "Column2", "Column3")
    For r = 2 To SummaryTable.Rows.Count
        For c = 2 To SummaryTable.Columns.Count
            OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)
            OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)
            OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)
            OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
            OutRow = OutRow + 1
        Next c
    Next r
End Sub
 
Назад
Сверху