CODEWITHSUNDEEP
vbaexcel
Todd Coplien
Todd Coplien

Reputation: 85

VBA Create Headings with Each New Section

I'm having some trouble figuring this out on my own and I think it is a combination of not knowing a ton of VBA and maybe not asking Google with the right keywords. I have some data that gets broken out into sections with the headings duplicated for each section. What I want to also do is create another hearder above the duplicated one that is a combination of text and various cells from the new sections. Each new header will be dependant on the data within its own section. If I was going to use the Concatenate formula for the 1st newly created section, it would be:

=CONCATENATE("Contract# ",J3," -- SiteID# ",L3)

The code I have for inserting the blank lines after each change in a specific column is below. It also duplicates the original header for each new section. I'm thinking I can combine the code I'm looking for with what I have. Unless it would just be easier to loop through each section and insert the new line above each of them? 

lr = Range("A" & Rows.Count).End(xlUp).Row
For i = lr To 3 Step -1
    If Cells(i - 1, "J").Value <> Cells(i, "J").Value Then
        Cells(i, "J").Resize(2).EntireRow.Insert
        Rows(1).Copy Destination:=Rows(i + 2)
    End If
Next i

Sorry. I knew I was forgetting something. Below is a screenshot of the data. Keep in mind that the only constant is how many columns will contain data. How many sections there are and how many rows are in each section will vary from day to day.

enter image description here

As requested, here's a small sample of what I'd like it to look like.

enter image description here

Upvotes: 1

Views: 829

Answers (1)

Hambone
Hambone

Reputation: 16397

I don't think it would be easier to loop through each section -- I think you're on the right track.

This may not be exactly what you want, but hopefully it will give you an idea:

For i = lr To 3 Step -1
  If Cells(i - 1, "J").Value <> Cells(i, "J").Value And Cells(i, "J").Value <> "" Then
    Cells(i, "J").Resize(2).EntireRow.Insert
    Rows(1).Copy Destination:=Rows(i + 1)
    Range("A" & i).Value2 = "Contract# " & Range("J" & i + 2).Value2 & _
         " -- SiteID# " & Range("L" & i + 2).Value2
  End If
Next i

This presupposes the field you want is in the header row in column A, above the copied header line.

-- EDIT 11/22/2016 --

Per OP's feedback of wanting to retain two blank lines, this should accomplish that.

For i = lr To 3 Step -1
  If Cells(i - 1, "J").Value <> Cells(i, "J").Value And Cells(i, "J").Value <> "" Then
    Cells(i, "J").Resize(4).EntireRow.Insert
    Rows(1).Copy Destination:=Rows(i + 3)
    Range("A" & i + 2).Value2 = "Contract# " & Range("J" & i + 4).Value2 & _
         " -- SiteID# " & Range("L" & i + 4).Value2
  End If
Next i

Minor edits might be in order to meet the specific needs, but hopefully this is 90%.

Upvotes: 2

Related Questions