时间戳

首页 > 解决方案 > 在没有 vbscript 的情况下转置 Excel 数据

excel - 在没有 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

源文件

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

标签： excelvba

解决方案

我想你想要这样的东西。

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

推荐阅读