VBA Help - Combine 2 Macros in One - Excel 2016

Johnny Thunder

Johnny Thunder

Well-known Member
Joined
Apr 9, 2010
Messages
693
Office Version
  1. 2016
Platform
  1. MacOS
Hello All,

I am working on a piece of code that loops through a range of cells and builds a Cell with data. I have the code working fine but I was not sure how to write the code in a way that I could have the code do 4 loops with varying column placement (C = #) . So as a workaround, I just wrote the same code 4 times and simply updated the column that the code looks at. Here is two of the 4 pieces of code so you can see what I mean

Any help is appreciated. Thanks!

So 1st Code looks at Column - C = 10
2nd - C = 12
3rd - C = 14
4th - C = 16

Here is the code

Code: 
'--------------------------------------------------------------
'--- Builds the Drama & Comedy Sheet Backlog Tiles - Resets Tile as well
'--------------------------------------------------------------
Sub MasterTimeline()


Dim ws1                 As Worksheet, ws2 As Worksheet
Dim r                      As Long, c As Long, Lastr2 As Long
Dim Title                As String, Season As String, AvailTime As String, Commitment As String, Genre As String, LastChar As String
Dim TitleLength     As Long, SeasonLength As String
Dim BlockVariable  As Variant, Shtname As Variant
   
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Set ws1 = Sheets("Master Timeline")
Set ws2 = Sheets("Master Data Entry")
Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row
'----------------------------- Filter Mode------------------------------------
On Error Resume Next
Sheets("Master Data Entry").ShowAllData 'Clear Filter
'----------------------------- Filter Mode------------------------------------


Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row


   r = 7 'Start at row 7
   c = 10 'Tile Start at Column 10 = J '<--------------------------------Here is where I need the revision of a loop as the code finishes one run, to go to the next C = # placement
   
   ws1.Range("J7:P41").ClearContents 'Clear tiles at the start - This is for the sorting
   
   For Each Cell In ws2.Range("B2:B" & Lastr2).SpecialCells(xlCellTypeVisible) 'Only grabs visible cells
      If Cell.Value = "Grid" And Cell.Offset(0, 1).Value = "Q1" Then 'If Backlog, bring it over, if Grid it means its already being used
         Title = Cell.Offset(0, 3).Value
         TitleLength = Len(Title)
         Season = Cell.Offset(0, 5).Value
         SeasonLength = Len(Season)
         Genre = Cell.Offset(0, 4).Value
         AvailTime = Cell.Offset(0, 10).Value
         Commitment = Cell.Offset(0, 11).Value
                                
        If Title <> "" Or Title <> "Title" Then
             With ws1.Cells(r, c)
                If SeasonLength = vbNullString Or SeasonLength = 0 Then 'If season is blank don't include the season text in Header of Title
                    .Value = Title & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 0
                 Else
                    .Value = Title & " | S" & Season & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 5
                End If
                    .Font.Name = "SF Hello (Body)"
                    .Font.FontStyle = "Regular"
                    .Font.Size = 13
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlTop
                    .IndentLevel = 0
                    LastChar = Len(ws1.Cells(r, c).Value)
                    With .Characters(Start:=1, Length:=TitleLength + SeasonLength).Font
                       .Name = "SF Hello (Body)"
                       .FontStyle = "Bold"
                       .Size = 20
                    End With
                    With .Characters(Start:=LastChar, Length:=1).Font
                       .Name = "Calibri (Body)"
                       .FontStyle = "Normal"
                       .Size = 1
                    End With
             End With
                               
            r = r + 2   'Steps down two rows
            
        End If 'If Title
     
     End If    'If Cell.value
   
   Next Cell 'Loop
   
   ws1.Cells.FormatConditions.Delete 'Deletes all Conditinal Formatting on Sheet before reapplying
   
   ws1.Range("J7").Select
    With ws1.Range("J7:P33")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=Countif(J7,""*Y"")"
        With .FormatConditions(.FormatConditions.Count)
            .SetFirstPriority
            With .Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.799981688894314
            End With
        End With
    End With
    
   Call MasterTimeline2
   Call MasterTimeline3
   Call MasterTimeline4
   
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True
   
   Calculate


End Sub
'--------------------------------------------------------------
'--- Builds the Drama & Comedy Sheet Backlog Tiles - Resets Tile as well
'--------------------------------------------------------------
Sub MasterTimeline2()


Dim ws1                 As Worksheet, ws2 As Worksheet
Dim r                      As Long, c As Long, Lastr2 As Long
Dim Title                As String, Season As String, AvailTime As String, Commitment As String, Genre As String, LastChar As String
Dim TitleLength     As Long, SeasonLength As String
Dim BlockVariable  As Variant, Shtname As Variant
  
Set ws1 = Sheets("Master Timeline")
Set ws2 = Sheets("Master Data Entry")


'----------------------------- Filter Mode------------------------------------
On Error Resume Next
Sheets("Master Data Entry").ShowAllData 'Clear Filter
'----------------------------- Filter Mode------------------------------------


Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row


   r = 7 'Start at row 7
   c = 12 'Tile Start at Column 12 = L
      
   For Each Cell In ws2.Range("B2:B" & Lastr2).SpecialCells(xlCellTypeVisible) 'Only grabs visible cells
      If Cell.Value = "Grid" And Cell.Offset(0, 1).Value = "Q2" Then 'If Backlog, bring it over, if Grid it means its already being used
         Title = Cell.Offset(0, 3).Value
         TitleLength = Len(Title)
         Season = Cell.Offset(0, 5).Value
         SeasonLength = Len(Season)
         Genre = Cell.Offset(0, 4).Value
         AvailTime = Cell.Offset(0, 10).Value
         Commitment = Cell.Offset(0, 11).Value
                                
        If Title <> "" Or Title <> "Title" Then
             With ws1.Cells(r, c)
                If SeasonLength = vbNullString Or SeasonLength = 0 Then 'If season is blank don't include the season text in Header of Title
                    .Value = Title & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 0
                 Else
                    .Value = Title & " | S" & Season & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 5
                End If
                    .Font.Name = "SF Hello (Body)"
                    .Font.FontStyle = "Regular"
                    .Font.Size = 13
                    .Font.ThemeColor = xlThemeColorLight1
                    .Font.TintAndShade = 0
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlTop
                    .IndentLevel = 0
                    LastChar = Len(ws1.Cells(r, c).Value)
                    With .Characters(Start:=1, Length:=TitleLength + SeasonLength).Font
                       .Name = "SF Hello (Body)"
                       .FontStyle = "Bold"
                       .Size = 20
                    End With
                    With .Characters(Start:=LastChar, Length:=1).Font
                       .Name = "Calibri (Body)"
                       .FontStyle = "Normal"
                       .Font.ThemeColor = xlThemeColorLight1
                       .Font.TintAndShade = 0
                       .Size = 1
                    End With
             End With
             
              r = r + 2   'Steps down two rows
        
        End If 'If Title
     
     End If    'If Cell.value
    
   Next Cell 'Loop
   
   Calculate


End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
I haven't deciphered all your code, but can't you just do this?

Code: 
    For c = 10 to 16 Step 2
 
Upvote 0
I will give that a shot. I am not super versed in the step syntax but today is a learning kinda day so I will see what happens.
 
Upvote 0
So I entered it into the code but I have a strong feeling I am putting it in the wrong placement of the loop. I moved it around but the it only messed up the output.

Code: 
'--------------------------------------------------------------
'--- Builds the Drama & Comedy Sheet Backlog Tiles - Resets Tile as well
'--------------------------------------------------------------
Sub MasterTimeline()


Dim ws1                 As Worksheet, ws2 As Worksheet
Dim r                      As Long, c As Long, Lastr2 As Long
Dim Title                As String, Season As String, AvailTime As String, Commitment As String, Genre As String, LastChar As String
Dim TitleLength     As Long, SeasonLength As String
Dim BlockVariable  As Variant, Shtname As Variant
   
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Set ws1 = Sheets("Master Timeline")
Set ws2 = Sheets("Master Data Entry")
Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row
'----------------------------- Filter Mode------------------------------------
On Error Resume Next
Sheets("Master Data Entry").ShowAllData 'Clear Filter
'----------------------------- Filter Mode------------------------------------


Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row


   r = 7 'Start at row 7
   For c = 10 To 16 Step 2  'Tile Start at Column 10=J - 16=P '<-----------------------your suggestions
      
   ws1.Range("J7:P41").ClearContents 'Clear tiles at the start - This is for the sorting
   
   For Each Cell In ws2.Range("B2:B" & Lastr2).SpecialCells(xlCellTypeVisible) 'Only grabs visible cells
      If Cell.Value = "Grid" And Cell.Offset(0, 1).Value = "Q1" Then 'If Backlog, bring it over, if Grid it means its already being used
         Title = Cell.Offset(0, 3).Value
         TitleLength = Len(Title)
         Season = Cell.Offset(0, 5).Value
         SeasonLength = Len(Season)
         Genre = Cell.Offset(0, 4).Value
         AvailTime = Cell.Offset(0, 10).Value
         Commitment = Cell.Offset(0, 11).Value
                                
   
        
        If Title <> "" Or Title <> "Title" Then
             With ws1.Cells(r, c)
                If SeasonLength = vbNullString Or SeasonLength = 0 Then 'If season is blank don't include the season text in Header of Title
                    .Value = Title & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 0
                 Else
                    .Value = Title & " | S" & Season & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 5
                End If
                    .Font.Name = "SF Hello (Body)"
                    .Font.FontStyle = "Regular"
                    .Font.Size = 13
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlTop
                    .IndentLevel = 0
                    LastChar = Len(ws1.Cells(r, c).Value)
                    With .Characters(Start:=1, Length:=TitleLength + SeasonLength).Font
                       .Name = "SF Hello (Body)"
                       .FontStyle = "Bold"
                       .Size = 20
                    End With
                    With .Characters(Start:=LastChar, Length:=1).Font
                       .Name = "Calibri (Body)"
                       .FontStyle = "Normal"
                       .Size = 1
                    End With
             End With
                               
            r = r + 2   'Steps down two rows
                 
        End If 'If Title
     
     End If    'If Cell.value
      
   Next Cell 'Loop
   
   Next c '<-----------------------your suggestions
   
   ws1.Cells.FormatConditions.Delete 'Deletes all Conditinal Formatting on Sheet before reapplying
   
   ws1.Range("J7").Select
    With ws1.Range("J7:P33")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=Countif(J7,""*Y"")"
        With .FormatConditions(.FormatConditions.Count)
            .SetFirstPriority
            With .Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.799981688894314
            End With
        End With
    End With
    
'   Call MasterTimeline2 '<-------------Old Code that shifts columns over
'   Call MasterTimeline3 '<-------------Old Code that shifts columns over
'   Call MasterTimeline4 '<-------------Old Code that shifts columns over
   
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True
   
   Calculate


End Sub
 
Upvote 0
Again, I haven't totally figured out your code, but I believe the "r = 7" line should be right after the "For = 10 To 16 Step 2" line. Try stepping through your code using the F8 key to see what works and what doesn't.
 
Upvote 0
Woohoo! I figured it out. With your last comment and stepping thru I was able to spot what needed to change.

The revised working code below. Thanks for your help Eric!

Code: 
'--------------------------------------------------------------
'--- Builds the Drama & Comedy Sheet Backlog Tiles - Resets Tile as well
'--------------------------------------------------------------
Sub MasterTimeline()


Dim ws1                 As Worksheet, ws2 As Worksheet
Dim r                      As Long, c As Long, Lastr2 As Long, period As String
Dim Title                As String, Season As String, AvailTime As String, Commitment As String, Genre As String, LastChar As String
Dim TitleLength     As Long, SeasonLength As String
Dim BlockVariable  As Variant, Shtname As Variant
   
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Set ws1 = Sheets("Master Timeline")
Set ws2 = Sheets("Master Data Entry")
Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row
'----------------------------- Filter Mode------------------------------------
On Error Resume Next
Sheets("Master Data Entry").ShowAllData 'Clear Filter
'----------------------------- Filter Mode------------------------------------


Lastr2 = ws2.Range("E" & Rows.Count).End(xlUp).Row
    ws1.Range("J7:P41").ClearContents 'Clear tiles at the start - This is for the sorting
        period = 1 'For Quarter
   
   For c = 10 To 16 Step 2  'Tile Start at Column 10=J - 16=P
       r = 7 'Start at row 7 'Upon loop reset will stay as 7
            
   For Each Cell In ws2.Range("B2:B" & Lastr2).SpecialCells(xlCellTypeVisible) 'Only grabs visible cells
      If Cell.Value = "Grid" And Cell.Offset(0, 1).Value = "Q" & period Then 'If Backlog, bring it over, if Grid it means its already being used
         Title = Cell.Offset(0, 3).Value
         TitleLength = Len(Title)
         Season = Cell.Offset(0, 5).Value
         SeasonLength = Len(Season)
         Genre = Cell.Offset(0, 4).Value
         AvailTime = Cell.Offset(0, 10).Value
         Commitment = Cell.Offset(0, 11).Value
                                
        If Title <> "" Or Title <> "Title" Then
             With ws1.Cells(r, c)
                If SeasonLength = vbNullString Or SeasonLength = 0 Then 'If season is blank don't include the season text in Header of Title
                    .Value = Title & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 0
                 Else
                    .Value = Title & " | S" & Season & Chr(10) & Genre & Chr(10) & "Avail: " & AvailTime & Chr(10) & Commitment
                    SeasonLength = 5
                End If
                    .Font.Name = "SF Hello (Body)"
                    .Font.FontStyle = "Regular"
                    .Font.Size = 13
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlTop
                    .IndentLevel = 0
                    LastChar = Len(ws1.Cells(r, c).Value)
                    With .Characters(Start:=1, Length:=TitleLength + SeasonLength).Font
                       .Name = "SF Hello (Body)"
                       .FontStyle = "Bold"
                       .Size = 20
                    End With
                    With .Characters(Start:=LastChar, Length:=1).Font
                       .Name = "Calibri (Body)"
                       .FontStyle = "Normal"
                       .Size = 1
                    End With
             End With
                               
            r = r + 2   'Steps down two rows
            
        End If 'If Title
     
     End If    'If Cell.value
   
   Next Cell 'Loop
   
    period = period + 1
   
   Next c
      
   ws1.Cells.FormatConditions.Delete 'Deletes all Conditinal Formatting on Sheet before reapplying
   
   ws1.Range("J7").Select
    With ws1.Range("J7:P33")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=Countif(J7,""*Y"")"
        With .FormatConditions(.FormatConditions.Count)
            .SetFirstPriority
            With .Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.799981688894314
            End With
        End With
    End With
   
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
   
   Calculate


End Sub
 
Upvote 0
Nice! You got a solution to your question, and learned some new VBA debugging skills! :cool:
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
502
ItalianPlatinum
I
A
  • Question Question
VBA Combine macros in one depending on text string
Replies
2
Views
508
mumps
mumps
Young Grasshopper
  • Solved
Excel VBA / Loop to copy unknown number of columns underneath each other, and string to each cell, AND adjecent cells!
Replies
4
Views
838
kevin9999
K
D
  • Solved
VBA code to find all cell in Col D in sheet 1 which contains cell value without match case from range A1 to A10 in Sheet 2
Replies
3
Views
484
deba2020
D
L
  • Solved
Can someone help me with VBA code to split cell info into new row
Replies
6
Views
2K
Liverlee
L

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top