不使用vbscript转换Excel数据

我正在尝试自动转换excel数据（从列到行），并且我已经为工作正常的数据创建了宏。 但是我担心如果记录超过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

---

源文件

---

预期文件

---

我想你想要这样的东西

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

或者

也…考虑复制到一个新的表，如果超过了行限制。

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

---

由于Excel中的行数多于列数，因此在将列转换为行时，不能超过行数。此外，如果您试图访问超出Excel最大行/列数的单元格，则会抛出错误，因此您会注意到这一点。没有无声的数据丢失。如果有选项，至少我可以将超出的行粘贴到另一个工作表中。没有超出的行。将列转换为行时不会发生这种情况。Excel有

1048576

行，但只有

16384

列。这是列数的64倍。如果你仍然认为它确实发生了，请提供证据。我从未见过

1048576

行数不够的情况。如果是这样的话，你真的应该考虑一个真正的数据库而不是Excel表格。我添加了一个例子，如果你看看目前我的日期（a列）大约32K行，当列增加时，我该如何处理？啊，好吧，这不是真正的“转置”。但是，如果合并操作超出了行数，您应该考虑使用数据库而不是Excel。如果你把它分成两张纸，你的数据就会变得毫无用处，很难处理（取决于你以后想用它做什么）。但您可以检查

row>.Cells.Rows.Count是否为
，然后从新工作表的第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