我想要一个宏来将数据从多个工作表合并到一个工作表..这里我给出了示例..
Sheet 1
a1:Name b1:Age
a2:sathish b2:22
a3:sarathi b3:24
sheet 2
a1:Age b1:Name c1:Dept
a2:60 b2:saran c2:Comp sce
a3:31 b3:rajan c3:B.com
结果应该是这样的
合并工作表
a1:Name b1:Age c1:Dept
a2:sathish b2:22
a3:sarathi b3:24
a4:saran b4:60 c4:Comp sce
a5:rajan b5:31 c5:B.com
以下是我用于合并数据的代码 -
Sub巩固（）
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
StartRow = 1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub：
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
功能LastRow（sh作为工作表）
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
结束功能
函数LastCol（sh作为工作表） On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
结束功能
我可以合并数据，但无法根据列标题重新排列。 请提前帮助我..预先
答案 0 :(得分：1)
首先，我确定了代码中的一些错误和不良做法，然后考虑如何重新设计宏以实现目标。
第1期
On Error的主要目的是允许您在发生意外错误时整齐地终止。你不应该使用它来避免你期望的错误，你不应该忽略错误。
考虑函数LastRow和LastCol。在这两种情况下，如果查找失败，您将忽略该错误并继续。但这意味着这些函数返回的值不正确，因此在调用例程中会出现另一个错误。如果查找失败，您应该调查不要忽略。任何其他错误都是如此。
第2期
如果工作表为空，则返回Nothing。您可以为工作表调用函数LastRow和LastCol＆＃34; RDBMergeSheet＆＃34;当它是空的。代码应该是：
Set Rng = sh.Cells.Find( ...)
If Rng Is Nothing Then
' Sheet sh is empty
LastRow = 0
Else
LastRow = Rng.Row
End If
如果工作表为空，我将LastRow设置为0。这不再是错误的副作用，而是函数的记录功能：＆＃34;返回值= 0表示工作表为空。＆＃34;调用例程必须检查此值并跳过任何空工作表。还有其他方法，但关键点是：提供代码以整洁的方式处理预期或可能的错误。对于函数LastCol，您需要LastCol = Rng.Column。
第3期
函数语句的最小语法是：
Function Name( ... parameters ...) As ReturnType
两个函数语句应结束：As Long。
第4期
考虑：＆＃34; ActiveWorkbook.Worksheets（＆＃34; RDBMergeSheet＆＃34;）＆＃34;
如果您正在处理多个工作簿，ActiveWorkbook是不够的。如果您只处理一个工作簿，则ActiveWorkbook是不必要的。在了解Excel VBA之前，请不要使用多个工作簿。
第5期
删除工作表＆＃34; RDBMergeSheet＆＃34;然后重新创造它伤害了我的灵魂。更重要的是，你丢失了列标题。我将在重新设计下进一步讨论此事。
替换：
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
使用：
Set DestSh = Worksheets("RDBMergeSheet")
With DestSh
.Range(.Cells(2, 1), .Cells(Rows.Count, Columns.Count)).EntireRow.Delete
End With
您在代码中使用Rows.Count，With和Cells，因此我不会解释它们。
.Range(.Cells(RowTop, ColLeft), .Cells(RowBottom, ColRight))是一种使用左上角和右下角单元指定范围的简单方法。
我使用过.EntireRow所以我不需要列号。以下效果相同：
.Rows("2:" & Rows.Count).EntireRow.Delete
据我所知ClearContents（有些人赞成）与Delete具有相同的效果。它肯定需要相同的微秒数。对于上面的用法，请从工作表的第二行到最后一行删除任何值或格式。
上述更改意味着第1行未更改且列宽不会丢失。我不需要你使用的AutoFit。
第6期
请系统地命名变量。您使用StartRow作为第一行，shLast作为源工作表的最后一行，Last作为目标工作表的最后一行。接管维护宏的同事是否会发现这很容易理解？当这个宏需要一些维护时，你会在六个月内记住吗？
开发适合您的命名系统。更好的是，与同事聚在一起并同意一个系统，以便所有雇主的宏看起来都一样。记录该系统，以造福未来的员工。我将这些变量命名为：RowNumDestLast，RowNumSrcStart和RowNumSrcLast。即：＆lt;变量的目的＆gt; ＆LT;工作表＆GT; ＆lt;工作表中的目的＆gt;。这个系统适合我，但你的系统可能完全不同。一个好的系统的关键特性是你可以在一年内查看你的代码，并立即知道每个语句在做什么。
第7期
If shLast > 0 And shLast >= StartRow Then
您将StartRow设置为1并且永远不会更改它，以便shLast >= StartRow然后shLast > 0。以下就足够了：
If shLast >= StartRow Then
第8期
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
检查导致致命错误的条件是好的，但这是最可能的错误吗？即使您使用的是Excel 2003，也可以容纳65,535人和标题行。在超过最大行数之前，您将在工作簿上中断大小限制。
第9期
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
这包括要复制的范围中的标题行。由于我稍后会建议一种完全不同的方法，我不会建议进行修正。
第10期
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
为什么要单独粘贴值和格式？
<强>重新设计
通过上面的更正，代码排序有效。使用源数据，它将目标表设置为：
Age Name Dept
Name Age
Sathish 22
Sarathi 24
Age Name Dept
60 Saran Comp sce
31 Rajan B.com
这不是你所寻求的。所以这个答案的其余部分是关于设计：你如何实现你寻求的外观？有很多方法，但我提供了一个解释为什么我在没有讨论替代方案的情况下选择它。
关键问题：
我决定使用工作表中的现有列名＆＃34; RDBMergeSheet＆＃34;确定顺序。要为新列名准备宏，只需将该名称添加到＆＃34; RDBMergeSheet＆＃34;。如果我在源表中发现了一个不在＆＃34; RDBMergeSheet＆＃34;中的列名，我会在右边添加它。如果列名称拼写错误，则第二个决定将突出显示错误，但如果有人在源工作表中收集额外信息则不会带来好处。
我不会将格式复制到工作表＆＃34; RDBMergeSheet＆＃34;因为，如果源工作表的格式不同，则工作表的每一部分都是＆＃34; RDBMergeSheet＆＃34;会有所不同。
新陈述和解释
Const RowFirstData As Long = 2
Const WShtDestName As String = "RDBMergeSheet"
常量意味着我在代码中使用名称，并可以通过更改Const语句来更改值。
我假设每个工作表的第一行包含列名，第一个数据行是2.我使用常量来明确这个假设。可以使用它来编写处理不同数量的标题行的代码，但我还没有这样做，因为它会使代码复杂化，但收效甚微。
ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column
.Cells(1, Columns.Count)标识第1行的最后一列，我假设它是空白的。 .End(xlToLeft)是键盘Ctrl + Left的VBA等价物。如果.Cells(1, Columns.Count)为空，.Cells(1, Columns.Count).End(xlToLeft)会返回左侧第一个不为空的单元格。 .Column给出该单元格的列号。也就是说，此语句将ColNumDestStart设置为第1行中最后一个单元格的列号。
ColHeadDest = .Range(.Cells(1, 1), .Cells(1, ColNumDestLast)).Value
这会将第1行中的值复制到变体数组ColHeadDest。 ColHeadDest将通过此语句重新设置为(1 to 1, 1 to ColNumDestLast)。第一个维度用于行，其中只有一个，第二个维度用于列。
替换合并
我希望我已经为代码添加了enought注释。您仍需要更正的LastRow和LastCol。我本可以替换LastRow和LastCol，但我认为我已经提供了足够的新代码。
Option Explicit
Sub consolidate()
Dim ColHeadCrnt As String
Dim ColHeadDest() As Variant
Dim ColNumDestCrnt As Long
Dim ColNumDestLast As Long
Dim ColNumSrcCrnt As Long
Dim ColNumSrcLast As Long
Dim Found As Boolean
Dim RowNumDestCrnt As Long
Dim RowNumDestStart As Long
Dim RowNumSrcCrnt As Long
Dim RowNumSrcLast As Long
Dim WShtDest As Worksheet
Dim WShtSrc As Worksheet
Dim WShtSrcData() As Variant
Const RowNumFirstData As Long = 2
Const WShtDestName As String = "RDBMergeSheet"
'With Application
' .ScreenUpdating = False ' Don't use these
' .EnableEvents = False ' during development
'End With
Set WShtDest = Worksheets(WShtDestName)
With WShtDest
' Clear existing data and load column headings to ColHeadDest
.Rows("2:" & Rows.Count).EntireRow.Delete
ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column
ColHeadDest = .Range(.Cells(1, 1), _
.Cells(1, ColNumDestLast)).Value
End With
' Used during development to check array loaded correctly
'For ColNumDestCrnt = 1 To ColNumDestLast
' Debug.Print ColHeadDest(1, ColNumDestCrnt)
'Next
RowNumDestStart = RowNumFirstData ' Start for first source worksheet
For Each WShtSrc In Worksheets
ColNumSrcLast = LastCol(WShtSrc)
RowNumSrcLast = LastRow(WShtSrc)
If WShtSrc.Name <> WShtDestName And _
RowNumSrcLast <> 0 Then
' Source sheet is not destination sheet and it is not empty.
With WShtSrc
' Load entire worksheet to array
WShtSrcData = .Range(.Cells(1, 1), _
.Cells(RowNumSrcLast, ColNumSrcLast)).Value
End With
With WShtDest
For ColNumSrcCrnt = 1 To ColNumSrcLast
' For each column in source worksheet
Found = False
ColHeadCrnt = WShtSrcData(1, ColNumSrcCrnt)
' Find matching column in destination worksheet
For ColNumDestCrnt = 1 To ColNumDestLast
If ColHeadCrnt = ColHeadDest(1, ColNumDestCrnt) Then
Found = True
Exit For
End If
Next ColNumDestCrnt
If Not Found Then
' Current source column's name is not present in the
' destination sheet Add new column name to array and
' destination worksheet
ColNumDestLast = ColNumDestLast + 1
ReDim Preserve ColHeadDest(1 To 1, 1 To ColNumDestLast)
ColNumDestCrnt = ColNumDestLast
With .Cells(1, ColNumDestCrnt)
.Value = ColHeadCrnt
.Font.Color = RGB(255, 0, 0)
End With
ColHeadDest(1, ColNumDestCrnt) = ColHeadCrnt
End If
' I could extract data from WShtSrcData to another array
' suitable for downloading to a column of a worksheet but
' it is easier to move the data directly to the worksheet.
' Also, athought downloading via an array is marginally
' faster than direct access, loading the array will reduce,
' and perhaps eliminate, the time benefit of using an array.
RowNumDestCrnt = RowNumDestStart
For RowNumSrcCrnt = RowNumFirstData To RowNumSrcLast
' Copy value from array of source data to destination sheet
.Cells(RowNumDestCrnt, ColNumDestCrnt) = _
WShtSrcData(RowNumSrcCrnt, ColNumSrcCrnt)
RowNumDestCrnt = RowNumDestCrnt + 1
Next
Next ColNumSrcCrnt
End With ' WShtDest
' Adjust RowNumDestStart ready for next source worksheet
RowNumDestStart = RowNumDestStart + RowNumSrcLast - RowNumFirstData + 1
End If ' Not destination sheet and not empty source sheet
Next WShtSrc
With WShtDest
' Leave workbook with destination worksheet visible
.Activate
End With
'With Application
' .ScreenUpdating = True
' .EnableEvents = True
'End With
End Sub