Транспонирование данных Excel без vbscript

Question

Я пытаюсь автоматизировать преобразование (столбец в строку) данных Excel, и я создал Macro для того, что работает отлично.Но я боюсь, что, если записи превышают максимальную емкость строки в Excel.Есть ли альтернативный способ сделать это.Возможно ли, что если записи превышают один лист, он должен заполнить записи на другом листе или в другом файле Excel.

Sub macro_generate()
Dim maxRows As Long
Dim maxCols As Long
Dim data As Variant

    Dim path As String
Dim openWb As Workbook
Dim openWs As Worksheet

path = "D:\Informatica\9.6.1\server\infa_shared\NL_Power_Exposure\bespoke.xlsx"

Set openWb = Workbooks.Open(path)
Set openWs = openWb.Sheets("Sheet1")


maxRows = openWs.Cells(1, 1).End(xlDown).row
maxCols = openWs.Cells(1, 1).End(xlToRight).Column

data = Range(Cells(1, 1), Cells(maxRows, maxCols))

Dim newSht As Worksheet
Set newSht = Sheets.Add
ActiveSheet.Range("A:A").Select
Selection.NumberFormat = "@"
With newSht

    .Cells(1, 1).Value = "IMPORTID"
    .Cells(1, 2).Value = "DT"
    .Cells(1, 3).Value = "READING"
  '  .Cells(1, 4).Value = "Linien Name"
  '  .Cells(1, 5).Value = "Einheit"
   ' .Cells(1, 6).Value = "Date"
    '.Cells(1, 7).Value = "Value"

    Dim writeRow As Long
    writeRow = 2

    Dim col As Long
    col = 2
    Dim counter As Long
    counter = 2
    Dim row As Long

    Do While True

        row = 2
        Do While True

             'IMPORTID
            .Cells(writeRow, 1).Value = data(1, col)
            'DT
            .Cells(writeRow, 2).Value = data(row, 1)
            'READING
            .Cells(writeRow, 3).Value = data(row, col)


            writeRow = writeRow + 1
            counter = counter + 1

            If row = maxRows Then Exit Do 'Exit clause
            row = row + 1



        Loop

        If col = maxCols Then Exit Do 'exit cluase
        col = col + 1

    Loop

End With
openWb.Save
openWb.Close

End Sub

---

ИСТОЧНИК ФАЙЛ

COLA    | COLB      | COLC
1-Jan-18| C1        | D1 
2-Jan-18| C2        | D2 
3-Jan-18| C3        | D3 

---

ОЖИДАЕМЫЙ ФАЙЛ

COLA    | COLB 
1-Jan-18| C1   
2-Jan-18| C2   
3-Jan-18| C3   
1-Jan-18| D1   
2-Jan-18| D2   
3-Jan-18| D3 

Answer 1

Я думаю, вы хотите что-то вроде этого.

Sub CombineColumns1()
'updateby Extendoffice 20151030
    Dim xRng As Range
    Dim i As Integer
    Dim xLastRow As Integer
    Dim xTxt As String
    On Error Resume Next
    xTxt = Application.ActiveWindow.RangeSelection.Address
    Set xRng = Application.InputBox("please select the data range", "Kutools for Excel", xTxt, , , , , 8)
    If xRng Is Nothing Then Exit Sub
    xLastRow = xRng.Columns(1).Rows.Count + 1
    For i = 2 To xRng.Columns.Count
        Range(xRng.Cells(1, i), xRng.Cells(xRng.Columns(i).Rows.Count, i)).Cut
        ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
        xLastRow = xLastRow + xRng.Columns(i).Rows.Count
    Next
End Sub

Или ...

Sub CombineColumns()
Dim rng As Range
Dim iCol As Integer
Dim lastCell As Integer

Set rng = ActiveCell.CurrentRegion
lastCell = rng.Columns(1).Rows.Count + 1

For iCol = 2 To rng.Columns.Count
    Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.Count, iCol)).Cut
    ActiveSheet.Paste Destination:=Cells(lastCell, 1)
    lastCell = lastCell + rng.Columns(iCol).Rows.Count
Next iCol
End Sub

Также ... рассмотрите возможность копирования на новый лист, если вы превысили предел строки.

If j > 1048576 Then
    j = 2
    Set finalSheet = Sheets("Sheet2") 'create new sheet
End If