我有一张大的Excel表格（大约150列×7000行，每天都在增长），但需要以更好的方式提取信息。 我无法访问数据库软件，只能访问Excel。 我已经设法使用普通公式获得了我想要的结果，但是文件大小几乎是100mB（最初从4mB起）并且不可行 - 它太慢了。 我创建了一个只能部分解决问题的数据透视表。 我是VBA的新手，所以我在这里尝试了几个例子来尝试学习，但目前大多数都太复杂了。 理论上，“Convert row with columns of data into column with multiple rows in Excel”看起来部分解决了我的问题，但我无法让它运行！虽然我可以看到模块中的代码，但是当我按下运行按钮时它不会出现在宏列表中。 这是我开始的 -
Name1 Name2 Location Subject1 Subject2 Subject3
Fred Jones England Spanish Maths English
Peter Brown Germany English (empty) Maths
Erik Strong Sweden Chemistry English Biology
必填结果 -
Name1 Name2 Location No. Type
Fred Jones England Subject1 Spanish
Fred Jones England Subject2 Maths
Fred Jones England Subject3 English
Peter Brown Germany Subject1 English
Peter Brown Germany Subject3 Maths
Erik Strong Sweden Subject1 Chemistry
Erik Strong Sweden Subject2 English
Erik Strong Sweden Subject3 Biology
有人可以帮忙吗？谢谢！
答案 0 :(得分：1)
我想分享我经常使用的脚本。当您希望每个事务，事件等在一个单独的行上时，在单行上有多个事务，事件等时使用它。它需要包含相同数据类型的列（例如Subject1，Subject2，Subject3 ...），并且需要跨多行组合成一列（例如Subject）。
换句话说，您的数据如下所示：
Name Location Subject1 Subject2 Subject3
看起来像这样：
Name Location Subject1
Name Location Subject2
Name Location Subject3
此脚本假设您的固定列位于左侧，而要组合的列（并拆分为多行）位于右侧。我希望这有帮助！
Option Explicit
Sub MatrixConverter2_2()
' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006)
'
' *** Substantial changes made by Chris Brackett (updated 8/3/2016) ***
'
' You are welcome to redistribute this macro, but if you make substantial
' changes to it, please indicate so in this section along with your name.
' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data
' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'"
' The conversion allows for multiple header rows and columns.
'--------------------------------------------------
' This section declares variables for use in the script
Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String
Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long
Dim headers(100) As Variant
Dim dun As Boolean
'--------------------------------------------------
' This section sets the script defaults
defaultHeaderRows = 1
defaultHeaderColumns = 2
DefaultRowName = "Activity"
'--------------------------------------------------
' This section asks about data types, row headers, and column headers
UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel)
If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro
all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel)
If all = vbCancel Then GoTo EndMatrixMacro
' UN-COMMENT THIS SECTION TO ALLOW FOR MULTIPLE HEADER ROWS
rowz = 1
' rowz = InputBox("How many HEADER ROWS?" & vbNewLine & vbNewLine & "(Usually 1)", "Header Rows & Columns", defaultHeaderRows)
' If rowz = vbNullString Then GoTo EndMatrixMacro
colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns)
If colz = vbNullString Then GoTo EndMatrixMacro
'--------------------------------------------------
' This section allows the user to provide field (column) names for the new spreadsheet
selectionCols = Selection.Columns.Count ' get the number of columns in the selection
For r = 1 To selectionCols
headers(r) = Selection.Cells(1, r).Offset(rowOffset:=-1, columnOffset:=0).Value ' save the column headers to use as defaults for user provided names
Next r
colz = colz * 1
columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"
Dim Arr(20) As Variant
newcol = 1
For r = 1 To rowz
If r = 1 Then RowName = DefaultRowName
Arr(newcol) = InputBox("Field name for the fields/columns to be combined" & vbNewLine & vbNewLine & columnsToCombine, , RowName)
If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
newcol = newcol + 1
Next
For c = 1 To colz
ColName = headers(c)
Arr(newcol) = InputBox("Field name for column " & c, , ColName)
If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
newcol = newcol + 1
Next
Arr(newcol) = "Data"
v = newcol
'--------------------------------------------------
' This section creates the new spreadsheet, names it, and color codes the new worksheet tab
mtrx = ActiveSheet.Name
Sheets.Add After:=ActiveSheet
dbase = "DB of " & mtrx
'--------------------------------------------------
' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters.
If Len(dbase) > 28 Then dbase = Left(dbase, 28)
'--------------------------------------------------
' This section checks if the proposed worksheet name
' already exists and appends adds a sequential number
' to the name
Dim sheetExists As Variant
Dim Sheet As Worksheet
Dim iName As Integer
Dim dbaseOld As String
dbaseOld = dbase ' save the original proposed name of the new worksheet
iName = 0
sheetExists = False
CheckWorksheetNames:
For Each Sheet In Worksheets ' loop through every worksheet in the workbook
If dbase = Sheet.Name Then
sheetExists = True
iName = iName + 1
dbase = Left(dbase, Len(dbase) - 1) & " " & iName
GoTo CheckWorksheetNames
' Exit For
End If
Next Sheet
'--------------------------------------------------
' This section notify the user if the proposed
' worksheet name is already being used and the new
' worksheet was given an alternate name
If sheetExists = True Then
MsgBox "The worksheet '" & dbaseOld & "' already exists. Renaming to '" & dbase & "'."
End If
'--------------------------------------------------
' This section creates and names a new worksheet
On Error Resume Next 'Ignore errors
If Sheets("" & Range(dbase) & "") Is Nothing Then ' If the worksheet name doesn't exist
ActiveSheet.Name = dbase ' Rename newly created worksheet
Else
MsgBox "Cannot name the worksheet '" & dbase & "'. A worksheet with that name already exists."
GoTo EndMatrixMacro
End If
On Error GoTo 0 ' Resume normal error handling
Sheets(dbase).Tab.ColorIndex = 41 ' color the worksheet tab
'--------------------------------------------------
' This section turns off screen and calculation updates so that the script
' can run faster. Updates are turned back on at the end of the script.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'--------------------------------------------------
'This section determines how many rows and columns the matrix has
dun = False
rotot = rowz + 1
Do
If (Sheets(mtrx).Cells(rotot, 1) > 0) Then
rotot = rotot + 1
Else
dun = True
End If
Loop Until dun
rotot = rotot - 1
dun = False
coltot = colz + 1
Do
If (Sheets(mtrx).Cells(1, coltot) > 0) Then
coltot = coltot + 1
Else
dun = True
End If
Loop Until dun
coltot = coltot - 1
'--------------------------------------------------
'This section writes the new field names to the new spreadsheet
For newcol = 1 To v
Sheets(dbase).Cells(1, newcol) = Arr(newcol)
Next
'--------------------------------------------------
'This section actually does the conversion
tot = 0
newro = 2
For col = (colz + 1) To coltot
For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero
If ((Sheets(mtrx).Cells(ro, col) <> 0) Or (all <> 6)) Then 'DCB modified ">0" to be "<>0" to exclude blank and zero cells
tot = tot + 1
newcol = 1
For r = 1 To rowz 'the next line copies the row headers
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col)
newcol = newcol + 1
Next
For c = 1 To colz 'the next line copies the column headers
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c)
newcol = newcol + 1
Next 'the next line copies the data
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col)
newro = newro + 1
End If
Next
Next
'--------------------------------------------------
'This section displays a message box with information about the conversion
book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10)
head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10)
cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data"
'--------------------------------------------------
' This section turns screen and calculation updates back ON.
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (book & head & cels)
'--------------------------------------------------
' This is an end point for the macro
EndMatrixMacro:
End Sub
答案 1 :(得分：0)
您可以使用转置功能，无论是否有VBA。这是我刚刚汇总的代码：
Sub test()
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lastColumn = ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Column
Dim rng As Range
With Sheets("Sheet2") ' the destination sheet
Set rng = .Range(.Cells(1, 1), .Cells(lastColumn, lastRow))
End With
rng.Value = _
Application.Transpose(ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn)))
End Sub