Excel将列转换为行
我有一个大的Excel工作表（大约150列x 7000行，每天都在增长），但需要以更好的方式提取信息。 我没有访问数据库软件，只有Excel。 我已经设法使用普通公式获得了我想要的结果，但是文件大小几乎是100mB（从最初的4mB开始），并且不可行 – 这太慢了。 我创build了一个只能部分解决问题的数据透视表。 我是VBA的新手，所以我在这里试了一些例子来学习，但是现在大多数对我来说太复杂了。 从理论上讲，“ 在Excel中将行与列的数据转换成多行 ”看起来部分解决了我的问题，但我却无法让它运行！ 虽然我可以看到模块中的代码，但当按下运行button时，它不会出现在macros列表中。 这是我开始的 –
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
任何人都可以帮忙吗？ 谢谢！
我想分享一个我经常使用的脚本。 如果您想在单独的行上logging每个事务，事件等，请在单行上有多个事务，事件等时使用它。 它需要包含相同数据types的列（例如，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
您可以使用带和不带VBA的转置function。 这里是我刚刚扔在一起的代码：
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