我正在尝试自动化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
答案 0 :(得分:0)
我想你想要这样的东西。
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