从不同的工作表获取列数据并将其作为MainSheet中的行数据

以下是从每张表的最后一列获取数据并将其显示在“MainSheet”表中的代码。 由于最后一列已经合并了单元格，所以这段代码也删除了这两个单元格之间的单元格。这段代码在MainSheet中将数据显示为垂直视图，并且我想使它成为水平的，即每张表格的最后一列的数据应该被提取到MainSheet和合并单元格应该照顾

Sub CopyLastColumns() Dim cnt As Integer, sht As Worksheet, mainsht As Worksheet, col As Integer, rw As Integer ActiveSheet.Name = "MainSheet" Set mainsht = Worksheets("MainSheet") cnt = 1 For Each sht In Worksheets If sht.Name <> "MainSheet" Then sht.Columns(sht.Range("A1").CurrentRegion.Columns.Count).Copy mainsht.Columns(cnt).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False mainsht.Cells(150, cnt) = sht.Range("A2") cnt = cnt + 1 End If Next sht With mainsht For col = 1 To cnt For rw = .Cells(65536, col).End(xlUp).row To 1 Step -1 If .Cells(rw, col) = "" Then .Cells(rw, col).Delete Shift:=xlUp End If Next rw Next col End With End Sub 

提前致谢

Answer 1

此代码复制每张工作表的最后一列，并将其作为MainSheet行进行粘贴，以保持合并的单元格不变。

 Option Explicit Sub Sample() Dim wsI As Worksheet, wsO As Worksheet Dim wsOLrow As Long, wsILrow As Long, wsILcol As Long On Error GoTo Whoa Application.ScreenUpdating = False Set wsO = Sheets("MainSheet") wsOLrow = wsO.Cells.Find(What:="*", _ After:=wsO.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row + 1 For Each wsI In ThisWorkbook.Sheets If wsI.Name <> wsO.Name Then With wsI wsILrow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row wsILcol = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column .Range(Split(Cells(, wsILcol).Address, "$")(1) & "1:" & _ Split(Cells(, wsILcol).Address, "$")(1) & _ wsILrow).Copy .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _ Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow) .Activate With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _ Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow) .UnMerge .Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp End With wsILrow = .Range(Split(Cells(, wsILcol).Address, "$")(1) & Rows.Count).End(xlUp).Row With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _ Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow) .Copy wsO.Cells(wsOLrow, 1).PasteSpecial Paste:=xlPasteAll, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=True .Delete End With wsOLrow = wsOLrow + 1 End With End If Next LetsContinue: Application.ScreenUpdating = True MsgBox "Done" Exit Sub Whoa: MsgBox Err.Description Resume LetsContinue End Sub