Vba 合并多表工作表中的数据，根据列名称重新排列数据_Vba

Vba 合并多表工作表中的数据，根据列名称重新排列数据

vba

Vba 合并多表工作表中的数据，根据列名称重新排列数据,vba,Vba,我需要一个宏来将数据从多个工作表合并到一个工作表。。这里我举了一个例子 Sheet 1 a1:Name b1:Age a2:sathish b2:22 a3:sarathi b3:24 结果应该是这样的合并表 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

我需要一个宏来将数据从多个工作表合并到一个工作表。。这里我举了一个例子

Sheet 1     
a1:Name     b1:Age

a2:sathish  b2:22   
a3:sarathi  b3:24

结果应该是这样的

合并表

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

下面是我用来合并数据的代码-

子合并（）

端接头

函数LastRow（sh作为工作表）

端函数

函数LastCol（sh作为工作表）出错时继续下一步

LastCol = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0

端函数

我可以合并数据，但不能按照列标题重新排列。。

请先帮助我。谢谢。

首先，我识别代码中的一些错误和坏习惯，然后考虑如何重新设计宏以实现您的目标。

第1期

出现错误时

的主要目的是允许您在发生意外错误时整齐地终止。您不应该使用它来避免预期的错误，也不应该忽略错误
考虑函数LastRow
和LastCol
。在这两种情况下，如果查找失败，则忽略错误并继续。但这意味着这些函数返回的值不正确，因此在调用例程中会出现另一个错误。如果查找失败，您应该进行调查，而不是忽略。任何其他错误都是如此
第二期
如果工作表为空，“查找”将不返回任何内容。当工作表“RDBMergeSheet”为空时，可以调用工作表“RDBMergeSheet”的函数LastRow
和LastCol
。代码应为：
Set Rng = sh.Cells.Find( ...)

If Rng Is Nothing Then
  ' Sheet sh is empty
  LastRow = 0
Else
  LastRow = Rng.Row
End If

如果工作表为空，我将LastRow设置为0。这不再是错误的副作用，而是函数的一个记录功能：“Return value=0表示工作表为空。”调用例程必须检查此值并跳过任何空工作表。还有其他方法，但关键是：提供代码以整洁的方式处理预期或可能的错误。对于函数LastCol，您需要LastCol=Rng.Column

第三期
函数语句的最低语法为：
Function Name( ... parameters ...) As ReturnType

这两条函数语句的结尾应为：尽可能长

第4期
考虑：“ActiveWorkbook.worksheet（“RDBMergeSheet”）”
如果您正在处理多个工作簿，ActiveWorkbook
是不够的。如果您只处理一个工作簿，ActiveWorkbook
是不必要的。在您更好地理解Excel VBA之前，请不要使用多个工作簿
第5期
你删除了工作表“RDBMergeSheet”，然后重新创建它，这伤害了我的灵魂。更重要的是，您丢失了列标题。我将在重新设计时进一步讨论这一问题
替换：
 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"

与：
您在代码中使用了行。计数
、和单元格
，因此我不会解释它们
.Range（.Cells（RowTop，ColLeft），.Cells（rowtom，ColRight））
是一种使用左上角和右下角单元格指定范围的简单方法
我使用了.EntireRow
，因此不需要列号。以下给出了相同的效果：
.Rows("2:" & Rows.Count).EntireRow.Delete

据我所知，ClearContents
（有些人喜欢）与Delete
具有相同的效果。这当然需要相同的微秒数。对于上述用法，这两种方法都可以删除工作表第二行到最后一行的所有值或格式
上述更改意味着第1行不变，列宽不会丢失。我不需要您使用的AutoFit
第6期
请系统地命名变量。将StartRow
用作源工作表的第一行，shLast
用作最后一行，last
用作目标工作表的最后一行。负责维护宏的同事会觉得这很容易理解吗？你还记得六个月后这个宏需要维护吗
开发一个适合您的命名系统。更妙的是，与同事一起商定一个单一的系统，这样你雇主的所有宏看起来都一样。为未来员工的利益记录此系统。我将这些变量命名为：RowNumDestLast、RowNumSrcStart和rownumsrcast。即：。这个系统适合我，但你的系统可能完全不同。一个好的系统的关键特性是，您可以在一年内查看您的代码，并立即知道每个语句在做什么
第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

您可以检查是否存在会导致致命错误的情况，但这是最可能的错误吗？即使您使用的是Excel2003，您也可以容纳65535人和标题行。在超出最大行数之前，您将打破工作簿的大小限制
第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

这不是你想要的。所以这个答案的其余部分是关于设计的：你如何实现你所追求的外观？有很多方法，但我提供了一个，并解释了为什么我选择了它而没有讨论其他方法
关键问题：

如何确定要合并的列以及顺序
如果源工作表中有一列是您不希望看到的，您会怎么做？有人在收集inf吗
If shLast >= StartRow Then

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

Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

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

  Const RowFirstData As Long = 2
  Const WShtDestName As String = "RDBMergeSheet"

    ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column

    ColHeadDest = .Range(.Cells(1, 1), .Cells(1, ColNumDestLast)).Value

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