Vba Help - For Loop to enter Text into Cell - Excel 2016

[Johnny Thunder]

Hello all,

I am working on a project and I have gotten fairly far with this and needed some guidance and possibly some revisions to my code to make it faster and shorter.

Objective:
1. I have a Master Data Sheet (Ws2) that has 17 rows of data Columns("B:O"). Thru a loop on Column B, if the value is "Backlog" then define all the attributes in that row with various Strings.
2. On my second Sheet (Ws1) I am creating a grid 2 Columns Wide, x amount of rows (based on how many values are on (Ws2), there is 1 blank row in between every cell of Data.

Problem:
I have the code able to populate all the details in each cell, I am running into an issue because I only want to have 14 Populated Cells per Column and I have two columns to work with. So what I was trying to do is have the For Each Loop stop at the 14th pasted text, and then move back up to the start (H7) and shift over 4 columns and continue pasting the text strings.

I feel like I was doing a weird roundabout way of defining when to stop by getting to row 35 with the loop and trying to manually shift back up to H7 and then shift over to the next column.


Any help is appreciated, I feel like this could probably be done faster/smarter with a "For i = 1 to 33" Kinda loop instead but I am not saavy with that code.
Here is the code:

Sub DramaTest()


Dim ws1 As Worksheet, ws2 As Worksheet
Dim CurrCell As Range
Dim LastR As Long, LastR2 As Long
Dim Title As String, Genre As String, Season As String, Tier As String, EPCount As String, EPMethod As String, EPMethodCount As String, AvailTime As String, Commitment As String, ProductionStart As String, PostProduction As String, GridStatus
Dim TitleLength As Variant, ColumnP As String


Set ws1 = Sheets("Drama")
Set ws2 = Sheets("Master Data - Drama & Comedy")


LastR = ws1.Range("H" & Rows.Count).End(xlUp).Row 'Finds last row with data
LastR2 = ws2.Range("E" & Rows.Count).End(xlUp).Row 'Finds last row with data


Application.Goto ws1.Range("H7") 'Loop for Tile Details - Start at row 7


For Each Cell In ws2.Range("B2:B" & LastR2 & "") 'Currently has 17 Items
    If Cell.Value = "Backlog" Then
        Set CurrCell = ActiveCell
                GridStatus = Cell.Value
                Title = Cell.Offset(0, 3).Value
                TitleLength = Len(Title)
                Genre = Cell.Offset(0, 4).Value
                Season = Cell.Offset(0, 5).Value
                Tier = Cell.Offset(0, 6).Value
                EPCount = Cell.Offset(0, 7).Value
                EPMethod = Cell.Offset(0, 8).Value
                EPMethodCount = Cell.Offset(0, 9).Value
                AvailTime = Cell.Offset(0, 10).Value
                Commitment = Cell.Offset(0, 11).Value
                ProductionStart = Cell.Offset(0, 12).Value
                PostProduction = Cell.Offset(0, 13).Value
                ColumnP = 2
            
        If CurrCell.Row = 35 Then 'When you get to row 35 start in a new column
            CurrCell.Offset(-28, 0).Select 'Resets the activecell back to H7
            ColumnP = 4 'Defines the column to change too
            
        End If 'Currcell.row
        
                CurrCell.Offset(0, ColumnP).Value = Title & " | S" & Season & Chr(10) & "Avail Date: " & AvailTime & Chr(10) & "Committed: " & Commitment 'Enters the details of the data into each tile
                    With CurrCell.Offset(0, ColumnP).Characters(Start:=1, Length:=TitleLength + 5).Font 'Header Title Font +5 is for Additional Season Text
                        .Name = "Calibri (Body)"
                        .FontStyle = "Bold"
                        .Size = 16
                    End With
                    
                    With CurrCell.Offset(0, ColumnP).Characters(Start:=TitleLength + 6, Length:=100).Font 'Rest of the Text on Tile +6 is for skipping to the next row and adding in season text to the count
                                .Name = "Calibri (Body)"
                                .FontStyle = "Regular"
                                .Size = 14
                            End With
                            
                CurrCell.Offset(2, 0).Select 'Step down 2 rows
        
        End If 'If Backlog


Next Cell


End Sub

 

[Fluff]

Is there any code that you have left out?
From what I can see you are only populating 1 column on Ws1, not 2 & you are defining a lot of strings that never get used.

 

[Fluff]

How about

Sub JohnnyThunder()
   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
   Dim TitleLength As Long
   
   
   Set ws1 = Sheets("Drama")
   Set ws2 = Sheets("Master Data - Drama & Comedy")
   LastR2 = ws2.Range("E" & Rows.Count).End(xlUp).Row
   r = 7
   c = 10
   For Each Cell In ws2.Range("B2:B" & LastR2 & "") 'Currently has 17 Items
      If Cell.Value = "Backlog" Then
         Title = Cell.Offset(0, 3).Value
         TitleLength = Len(Title)
         Season = Cell.Offset(0, 5).Value
         AvailTime = Cell.Offset(0, 10).Value
         Commitment = Cell.Offset(0, 11).Value
           
         With ws1.Cells(r, c)
            .Value = Title & " | S" & Season & Chr(10) & "Avail Date: " & AvailTime & Chr(10) & "Committed: " & Commitment
            .Font.Name = "Calibri (Body)"
            .Font.FontStyle = "Regular"
            .Font.Size = 14
            With .Characters(Start:=1, Length:=TitleLength + 5).Font
               .Name = "Calibri (Body)"
               .FontStyle = "Bold"
               .Size = 16
            End With
         End With
         r = r + 2
         If r > 33 Then
            r = 7
            c = c + 4
         End If
      End If
   Next Cell
End Sub

 

[mikerickson]

Have you tried setting the .ScrollArea of the worksheet.

ActiveSheet.ScrollArea = "1:14"

 

[Johnny Thunder]

Thanks for the help Fluff, I will try out the proposed revisions today.

And in regards to your first question: Yes, there are several variables that I am defining but not using. The user has requested at this time not to use but I left them there because I am sure they will be used later. And as for only using one column, the variable string "ColumnP" was how I was trying to update the .Offset line to switch back and fourth between two columns but it wasn't working the method I thought it would.

 

[Johnny Thunder]

The code worked great and definitely cleaned up alot of what I was doing! Thanks again fluff!

How about

Sub JohnnyThunder()
   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
   Dim TitleLength As Long
   
   
   Set ws1 = Sheets("Drama")
   Set ws2 = Sheets("Master Data - Drama & Comedy")
   LastR2 = ws2.Range("E" & Rows.Count).End(xlUp).Row
   r = 7
   c = 10
   For Each Cell In ws2.Range("B2:B" & LastR2 & "") 'Currently has 17 Items
      If Cell.Value = "Backlog" Then
         Title = Cell.Offset(0, 3).Value
         TitleLength = Len(Title)
         Season = Cell.Offset(0, 5).Value
         AvailTime = Cell.Offset(0, 10).Value
         Commitment = Cell.Offset(0, 11).Value
           
         With ws1.Cells(r, c)
            .Value = Title & " | S" & Season & Chr(10) & "Avail Date: " & AvailTime & Chr(10) & "Committed: " & Commitment
            .Font.Name = "Calibri (Body)"
            .Font.FontStyle = "Regular"
            .Font.Size = 14
            With .Characters(Start:=1, Length:=TitleLength + 5).Font
               .Name = "Calibri (Body)"
               .FontStyle = "Bold"
               .Size = 16
            End With
         End With
         r = r + 2
         If r > 33 Then
            r = 7
            c = c + 4
         End If
      End If
   Next Cell
End Sub

 

[Fluff]

You're welcome & thanks for the feedback