Excel горизонтальное и вертикальное расположение один за другим

Question

Range("A19:C19").Select
Selection.Copy
Sheets("Sheet5").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Sheets("Sheet1").Select
Range("A20:C20").Select
Selection.Copy
Sheets("Sheet5").Select
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

так что в основном у меня есть данные по горизонтали, что при транспонировании они располагаются по вертикали, но строки

Я хочу один за другим Как в

A19 - Hyperlink
B19 - String
C19 - String
Space
A20 - HyperLink
B20 - String
C20 - String

И так on ..

Например ...

хотели бы, чтобы эти данные выглядели так

Answer 1

Тривиально с Power Query:

• Добавить пользовательский столбец с формулой: = " " (пробел)
• Выбрать все столбцы и «UnPivot»
• Удалить столбец атрибута
• В столбце Значение замените пробел на ноль

Если вы добавляете / изменяете строки (или столбцы) ), просто измените sh запрос.

M-код

let
    Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}}),
    #"Added Custom" = Table.AddColumn(#"Changed Type", "Custom", each " "),
    #"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Added Custom", {}, "Attribute", "Value"),
    #"Replaced Value1" = Table.ReplaceValue(#"Unpivoted Columns"," ",null,Replacer.ReplaceValue,{"Value"}),
    #"Removed Columns" = Table.RemoveColumns(#"Replaced Value1",{"Attribute"})
in
    #"Removed Columns"

Если у вас нет доступа к Power Query , и из вашего комментария это кажется может существовать установленная компанией политика в отношении загрузки надстроек, даже если они от Microsoft, тогда вы можете использовать VBA.

Обязательно прочитайте комментарии в коде, чтобы помочь понять, что он делает.

Я предлагаю раннее связывание, как написано, так как вы получаете преимущества от intellisense и более эффективного выполнения. Но если вы собираетесь распространять код, позднее связывание может быть лучше.

'Set reference to Microsoft Scripting Runtime
'  (or you could use late binding)
Option Explicit
Sub organizeData()
    Dim D As Dictionary, COL As Collection
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim C As Range
    Dim I As Long, J As Long, V As Variant, W As Variant

'Set source and results worksheets and ranges
Set wsSrc = ThisWorkbook.Worksheets("Sheet7") 'or whatever

    'Assuming first cell is the first cell starting with "http"
    ' but could make other assumptions, or even hard code.
    'Also assuming the source data range is contiguous.
    With wsSrc
        Set C = .Cells.Find(what:="http*", LookIn:=xlValues, lookat:=xlWhole, _
                            searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)

        If C Is Nothing Then
            MsgBox "No cell starting with http"
            Exit Sub
        End If

        'Read into variant array for speed of processing
        vSrc = C.CurrentRegion
    End With

    'for purposes of convenience, will put results onto same worksheet,
    'below the source data, but could write it to another area or sheet,
    'or even overwrite the original data, but I would not advise this latter.
    Set wsRes = Worksheets("Sheet7")
    Set rRes = wsRes.Cells(10, 2)

'Read the data into a dictionary, with each dictionary representing one line of data
Set D = New Dictionary
For I = 1 To UBound(vSrc, 1) 'if there is a header row, then start with 2
    Set COL = New Collection
    For J = 1 To UBound(vSrc, 2)

    'decide how you want to handle empty data
    'I will NOT include a blank row, (except between groups), but you can change that behavior here
        If Not Trim(vSrc(I, J)) = "" Then COL.Add vSrc(I, J)
    Next J
        D.Add Key:=I, Item:=COL
Next I

'Create results array
'If leaving blanks for empty rows, don't need this computation,
'  but it won't hurt to leave it in.

'Get number of rows
I = D.Count 'for the blank rows
For Each V In D
    I = I + D(V).Count 'for each eventual rows
Next V

'if going to write a header row, start then use ...(0 to 1, 1 to 1)
'   and write the header into vRes(0,1)
ReDim vRes(1 To I, 1 To 1)

'Get the data and populate the array
I = 0
For Each V In D
    For J = 1 To D(V).Count
        I = I + 1
        vRes(I, 1) = D(V)(J)
    Next J
    I = I + 1
Next V

'write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1) - 1) 'else last row would be blank
With rRes
    Range(rRes, Cells(wsRes.Rows.Count, .Column)).Clear
    .Value = vRes
    .Style = "Output"
    .EntireColumn.AutoFit
End With

End Sub

mgur.com / fvd5K.png

Answer 2

В дополнение к подходу Рона это демонстрирует два коротких и довольно простых решения для реорганизации горизонтальных данных в одну вертикаль, включая пробелы.

a) подход блочного массива

Просто для удовольствия решение блочного массива; измените ExampleCall() процедуру в соответствии с вашими потребностями (я воздержался от определения исходного или целевого диапазонов, чтобы оно было коротким) :

Option Explicit

Sub ExampleCall()
With Sheet1                              ' << change to your sheet's VB Editor's Code(Name)
    ReOrg .Range("A2:C4"), .Range("C10") ' args: source range, target range, number of blank rows
End With
End Sub

Sub ReOrg(src As Range, target As Range, Optional ByVal nBlanks As Long = 1)
    Dim v: v = src                       ' assign src to a 1-based 2-dim datafield array
    Dim BlockLength As Long: BlockLength = UBound(v, 2) + nBlanks
    Dim i As Long
    For i = 1 To UBound(v)               ' write original line data blockwise to target
        target.Offset((i - 1) * BlockLength).Resize(UBound(v, 2)) = Application.Transpose(Application.Index(v, i, 0))
    Next i
End Sub

---

b) Получение 1 массива последовательность через простую ячейку l oop - добавлено / 2020-04-09

Если вы предпочитаете реорганизовать массив вертикальных столбцов (также, возможно, в "плоский") через ячейку l oop, вы можете попробовать это:

Sub ExampleCall2()
    Dim arr
    arr = Rng2Arr(Sheet1.Range("A2:C4"), IsOneDim:=False) ' get vertical array (i.e. 2-dim)
    Sheet1.Range("C10").Resize(UBound(arr), 1) = arr      ' write original line data into any column
End Sub

Function Rng2Arr(ByVal rng As Range, Optional ByVal nBlanks As Long = 1, Optional IsOneDim As Boolean = True) As Variant()
'Purpose: return 1-based array; if IsOneDim then 1-dim "flat" array, otherwise 2-dim (1 column)
'Note:    assumes empty cells in added column(s); independant from Application.MoveAfterReturnDirection
    Set rng = rng.Resize(ColumnSize:=rng.Columns.Count + nBlanks)  ' provide for blank cell
    ReDim tmp(1 To rng.Cells.Count)                                ' temp array to hold cell values
    Dim c As Range, i As Long
    For Each c In rng: i = i + 1: tmp(i) = c: Next c               ' rowwise assignment to temp
    Rng2Arr = IIf(IsOneDim, tmp, Application.Transpose(tmp))       ' return type following your preferences
End Function