• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro help - code changes

Hi Guys - I have to summarize the data from multiple worksheets to one WS. I have the following code which create the summary sheet but need couple more changes highlighted in yellow, if you can help: Thanks


1554732287359-png.59332
 

Attachments

  • 1554732287359.png
    1554732287359.png
    351.8 KB · Views: 52
  • Consol.xlsm
    60.1 KB · Views: 5
Clean code below. I have very simple requests to amend the code to include following 3 (highlighted in purple within the code)

' delete rows 1-5 in each worksheet
' only copy rows from the worksheets upto the month where column F or G has a value and ignore the rest
' copy formatting of existing sheets to summary sheet

Code:
Option Explicit  
    Public Sub CombineSheetsWithDifferentHeaders()
    Dim wksDst As Worksheet, wksSrc As Worksheet
    Dim lngIdx As Long, lngLastSrcColNum As Long, _
    lngFinalHeadersCounter As Long, lngFinalHeadersSize As Long, _
    lngLastSrcRowNum As Long, lngLastDstRowNum As Long
    Dim strColHeader As String
    Dim varColHeader As Variant
    Dim rngDst As Range, rngSrc As Range
    Dim dicFinalHeaders As Scripting.Dictionary
    Set dicFinalHeaders = New Scripting.Dictionary
   
    dicFinalHeaders.CompareMode = vbTextCompare
    lngFinalHeadersCounter = 1
    lngFinalHeadersSize = dicFinalHeaders.Count
   
' delete rows 1-5 in each worksheet
Set wksDst = ThisWorkbook.Worksheets.Add
   
   
    For Each wksSrc In ThisWorkbook.Worksheets
   
    If wksSrc.Name <> wksDst.Name Then
    With wksSrc
   
    lngLastSrcColNum = LastOccupiedColNum(wksSrc)
    For lngIdx = 1 To lngLastSrcColNum
   
    strColHeader = Trim(CStr(.Cells(1, lngIdx)))
    If Not dicFinalHeaders.Exists(strColHeader) Then
    dicFinalHeaders.Add Key:=strColHeader, _
    Item:=lngFinalHeadersCounter
    lngFinalHeadersCounter = lngFinalHeadersCounter + 1
    End If
    Next lngIdx
    End With
    End If
    Next wksSrc
   
    For Each varColHeader In dicFinalHeaders.Keys
    wksDst.Cells(1, dicFinalHeaders(varColHeader)) = CStr(varColHeader)
    Next varColHeader
   
    ' only copy rows upto the month where column F or G has a value and ignore the rest

    For Each wksSrc In ThisWorkbook.Worksheets
   
    If wksSrc.Name <> wksDst.Name Then
    With wksSrc
   
    lngLastSrcRowNum = LastOccupiedRowNum(wksSrc)
    lngLastSrcColNum = LastOccupiedColNum(wksSrc)
   
    lngLastDstRowNum = LastOccupiedRowNum(wksDst)
   
    For lngIdx = 1 To lngLastSrcColNum
    strColHeader = Trim(CStr(.Cells(1, lngIdx)))
   
    Set rngDst = wksDst.Cells(lngLastDstRowNum + 1, _
    dicFinalHeaders(strColHeader))
   
    Set rngSrc = .Range(.Cells(2, lngIdx), _
    .Cells(lngLastSrcRowNum, lngIdx))
   
    rngSrc.Copy Destination:=rngDst
    Next lngIdx
    End With
    End If
    Next wksSrc
   
    MsgBox "Data combined!"
    End Sub
   
    Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
    With Sheet
    lng = .Cells.Find(What:="*", _
    After:=.Range("A1"), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
    End With
    Else
    lng = 1
    End If
    LastOccupiedRowNum = lng
    End Function
   
    Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
    With Sheet
    lng = .Cells.Find(What:="*", _
    After:=.Range("A1"), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByColumns, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Column
    End With
    Else
    lng = 1
    End If
    LastOccupiedColNum = lng
   
' copy formatting of existing sheets to summary sheet
  
    End Function
 

Attachments

  • 1554816613574.png
    1554816613574.png
    7.4 KB · Views: 3
Last edited:
Back
Top