Consulting

Results 1 to 2 of 2

Thread: Combine specific worksheets and columns with modified generic code

  1. #1
    VBAX Newbie
    Joined
    Aug 2011
    Posts
    1
    Location

    Combine specific worksheets and columns with modified generic code

    I'd like to combine specific worksheets with specific columns from each worksheet into a master worksheet, and keep them sorted by date. For example Columns A, B, C from Worksheets 2010, 2009, 2008 where column A in each worksheet is a date. The columns in each worksheet have the same data and headers. I copied the generic code from msdn.microsoft.com to combine multiple worksheets, but I dont know which lines or what to put in those lines to suit my needs. Obviously, I'm a novice and would appreciate any help. Cutting and pasting is very time consuming. Here is the code I copied.

    Sub CopyDataWithoutHeaders()
    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
    ' Delete the summary sheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    ' Add a new summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"
    ' Fill in the start row.
    StartRow = 2
    ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
    ' Find the last row with data on the summary
    ' and source worksheets.
    Last = LastRow(DestSh)
    shLast = LastRow(sh)
    ' If source worksheet is not empty and if the last
    ' row >= StartRow, copy the range.
    If shLast > 0 And shLast >= StartRow Then
    'Set the range that you want to copy
    Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
    ' Test to see whether there are enough rows in the summary
    ' worksheet to copy all the data.
    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
    ' This statement copies values and formats.
    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)
    ' AutoFit the column width in the summary sheet.
    DestSh.Columns.AutoFit
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
    End Sub

  2. #2
    VBAX Expert CatDaddy's Avatar
    Joined
    Jun 2011
    Posts
    581
    Location
    [vba]Sub CombineWS()
    ActiveWorkbook.Sheets(1).Activate
    Range("A1").Activate
    Dim i As Integer
    For i = 4 To 2 Step -1
    Sheets(i).Activate
    Range("A2:C" & Range("A65600").End(xlUp).Row).Select
    Selection.Copy Destination:=Worksheets("Master").Range("A" & Worksheets("Master").Range("A65600").End(xlUp).Offset(1, 0).Row)
    Next i
    Worksheets("Master").Activate
    Columns("A:A").Select
    ActiveWorkbook.Worksheets("Master").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Master").Sort.SortFields.Add Key:=Range("A1"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Master").Sort
    .SetRange Range("A2:C20")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    End Sub[/vba]
    Attached Files Attached Files
    ------------------------------------------------
    Happy Coding my friends

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •