Consolitate data from multible sheets ,re-arrange the data as per the column name

i want a macro to consolidate th开发者_开发问答e data form multiple sheets to one sheet.. here i given the example ..

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

the result should be like this

consolidate sheet

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

Here is the code which i used for consolidate data-

Sub consolidate()

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

Function LastRow(sh As Worksheet)

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

End Function

Function LastCol(sh As Worksheet) 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

End Function

I can able consolidate the data but can't re-arrange as per the column title.. Please help me in this ..THanks in advance

---

First I identify some mistakes and bad practices in your code then I consider how to redesign your macro to achieve your objectives.

Issue 1

The primary purpose of On Error is to allow you to terminate tidily if an unexpected error occurs. You should not use it to avoid errors you expect and you should not ignore errors.

Consider the functions LastRow and LastCol. In both cases, if the Find fails, you ignore the error and carry on. But that means these functions return an incorrect value, so you get another error in the calling routine. If the Find fails you should investigate not ignore. This is true of any other error.

Issue 2

Find returns Nothing if the sheet is empty. You call functions LastRow and LastCol for worksheet "RDBMergeSheet" when it is empty. The code should be:

Set Rng = sh.Cells.Find( ...)

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

Here I have set LastRow to 0 if the worksheet is empty. This ceases to be a side effect of an error but a documented feature of the function: "Return value = 0 means the worksheet is empty." The calling routine must check for this value and skip any empty worksheets. There are other approaches but the key point is: provide code to handle expected or possible errors in a tidy manner. For function LastCol you need LastCol = Rng.Column.

Issue 3

The minimum syntax for a function statement is:

Function Name( ... parameters ...) As ReturnType

The two function statements should end: As Long.

Issue 4

Consider: "ActiveWorkbook.Worksheets("RDBMergeSheet")"

If you are working on multiple workbooks, ActiveWorkbook is not enough. If you are only working on one workbook, ActiveWorkbook is unnecessary. Please do not work with multiple workbooks until your understanding of Excel VBA is better.

Issue 5

You delete worksheet "RDBMergeSheet" and then recreate it which hurts my soul. More importantly, you have lost the column headings. I will discuss this matter further under Redesign.

Replace:

 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"

with:

 Set DestSh = Worksheets("RDBMergeSheet")
 With DestSh
   .Range(.Cells(2, 1), .Cells(Rows.Count, Columns.Count)).EntireRow.Delete
 End With

You use Rows.Count, With and Cells in your code so I will not explain them.

.Range(.Cells(RowTop, ColLeft), .Cells(RowBottom, ColRight)) is an easy method of specifying a range with the top left and bottom right cells.

I have used .EntireRow so I do not need the column numbers. The following gives the same effect:

.Rows("2:" & Rows.Count).EntireRow.Delete

As far as I know ClearContents (which some people favour) has the same effect as Delete. It certainly takes the same number of micro-seconds. For the usages above, both remove any values or formatting from the second row to the last row of the worksheet.

The above change means that row 1 is unchanged and the column widths are not lost. I do not need AutoFit which you have used.

Issue 6

Please be systematic in the naming of your variables. You use StartRow as the first row and shLast as the last row of the source worksheet and Last as the last row of the destination worksheet. Will a colleague who takes over maintenance of your macro find this easy to understand? Will you remember it in six months when this macro needs some maintenance?

Develop a naming system that works for you. Better still, get together with colleagues and agree a single system so all your employer's macros look the same. Document this system for the benefit of future staff. I would name these variables: RowNumDestLast, RowNumSrcStart and RowNumSrcLast. That is: <purpose of variable> <worksheet> <purpose within worksheet>. This system works for me but your system could be completely different. The key feature of a good system is that you can look at your code in a year and immediately know what each statement is doing.

Issue 7

If shLast > 0 And shLast >= StartRow Then

You set StartRow to 1 and never change it so if shLast >= StartRow then shLast > 0. The following is enough:

If shLast >= StartRow Then

Issue 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

It is good that you are checking for conditions that will result in fatal errors but is this the most likely error? Even if you are using Excel 2003, you have room for 65,535 people and a heading line. You will break the size limit on a workbook before you exceed the maximum number of rows.

Issue 9

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

This includes the heading row in the range to be copied. Since I will suggest a totally different method later, I will not suggest a correction.

Issue 10

With DestSh.Cells(Last + 1, "A")
  .PasteSpecial xlPasteValues
  .PasteSpecial xlPasteFormats

Why are you pasting the values and formats separately?

Redesign

With the corrections above, the code sort of works. With your source data, it sets the destination sheet to:

Age      Name    Dept
Name     Age    
Sathish  22 
Sarathi  24 
Age      Name    Dept
60       Saran   Comp sce
31       Rajan   B.com

This is not what you seek. So the rest of this answer is about design: how do you achieve the appearance you seek? There are many approaches but I offer one and explain why I have picked it without discussing alternatives.

Key issues:

• How do you determine which columns to consolidate and in which sequence?
• If there is a column in a source worksheet that you are not expecting, what do you do? Is someone collecting information for which there is no central interest or is the column name misspelt?

I have decided to use the existing column names within worksheet "RDBMergeSheet" to determine the sequence. To prepare the macro for a new column name, just add that name to "RDBMergeSheet". If I discover a column name in a source sheet that is not in "RDBMergeSheet", I add it on the right. This second decision will highlight the error if a column name is misspelt but will not be a benefit if someone is collecting extra information in a source worksheet.

I do not copy formats to worksheet "RDBMergeSheet" since, if the source worksheets are formatted differently, each part of worksheet "RDBMergeSheet" would be different.

New statements and explanations

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

A constant means I use the name in the code and can change the value by changing the Const statement.

I assume the first row of every worksheet contains column names and the first data row is 2. I use a constant to make this assumption clear. It would be possible to use this to write code that would handle a different number of heading rows but I have not done so because it would complicate the code for little advantage.

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

.Cells(1, Columns.Count) identifies the last column of row 1 which I assume is blank. .End(xlToLeft) is the VBA equivalent of the keyboard Ctrl+Left. If .Cells(1, Columns.Count) is blank, .Cells(1, Columns.Count).End(xlToLeft) returns the first cell to the left which is not blank. .Column gives the column number of that cell. That is, this statement sets ColNumDestStart to the column number of the last cell in row 1 with a value.

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

This copies the values from row 1 to the variant array ColHeadDest. ColHeadDest will be redimensioned by this statement to (1 to 1, 1 to ColNumDestLast). The first dimension is for the rows, of which there is only one, and the second dimension is for the columns.

Replacement consolidate

I hope I have added enought comments for the code to make sense. You still need the corrected LastRow and LastCol. I could have replaced LastRow and LastCol but I think I have provided enough new code to be getting on with.

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