How to add/organize mulitple headliners/rows in an

Question

I am new to this VBA and trying to learn more by watching videos on YouTubee and looking in some books and right now I'm stuck - can't come further - I hope someone will direct me to the right path or help me modifying the code.

First - I want to order/organize everytime I make a copy to the other sheet. With this code below I copy my data to the specific sheet that I want.

    Application.CopyObjectsWithCells = False
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim sourceCell As Range
    Dim targetSheet As Worksheet
    Dim StartRow As Integer
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Opgørsel")
    Set sourceCell = ws.Range("D3")  'Cell with sheet names for copying to
    StartRow = 1    'Destination row on targetSheet
    With ws
          Set targetSheet = wb.Worksheets(sourceCell.Text)
         .Range("A1").CurrentRegion.Copy
         targetSheet.Range("A" & StartRow).Insert Shift:=xlDown
         targetSheet.Columns.AutoFit
    End With
    Application.CutCopyMode = 1
    Application.ScreenUpdating = True
    Application.CopyObjectsWithCells = True

Then everytime I make a copy, I want to create a row/headliner that comes with the copy to that specific sheet. I do that with this part of the code.

Set findfirst = targetSheet.Range("H:H").Find("Tykkelse [m]")
 currentvalue = findfirst.Offset(1, -4).Value & " " & findfirst.Offset(1, 0).Value
  findfirst.Offset(-1, 0).EntireRow.Insert xlDown

With targetSheet.Range(Cells(findfirst.Row - 2, 1), Cells(findfirst.Row - 2, 14))
    .Merge
    .HorizontalAlignment = xlCenter
    .Interior.ColorIndex = 27
    .Font.Bold = 1
    .Font.Size = 18
    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    .Value = currentvalue
End With
Range("N1").Offset(1, 0).Value = Environ("Username")

What I want

My dataset in the first sheet.][

In the first sheet, I insert values under "Tykkelse [m]" in column H and "Radius [m]" in column J . So when I copy over, I want to create a headliner/row as above depending on if I insert a value in "Tykkelse [m]" or "Radius [m]" and if there are already a headliner/row to that, then copy the new copy right under the headliner/row.

This is happening right now.][

This is what I want.][

In the pictures, you can see, what I get now with the code and what I want.

This is my current code in the modul and want to modify it that way, that it.

    Sub Copypastemeddata()
Application.CopyObjectsWithCells = False
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim sourceCell As Range
    Dim targetSheet As Worksheet
    Dim StartRow As Integer
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Opgørsel")
    Set sourceCell = ws.Range("D3")  'Cell with sheet names for copying to
    StartRow = 1    'Destination row on targetSheet
    With ws

          Set targetSheet = wb.Worksheets(sourceCell.Text)
         .Range("A1").CurrentRegion.Copy
         targetSheet.Range("A" & StartRow).Insert Shift:=xlDown
         targetSheet.Columns.AutoFit
    End With
    Application.CutCopyMode = 1
    Application.ScreenUpdating = True
Application.CopyObjectsWithCells = True
    Set findfirst = targetSheet.Range("H:H").Find("Tykkelse [m]")
        currentvalue = findfirst.Offset(1, -4).Value & " " & findfirst.Offset(1, 0).Value
        findfirst.Offset(-1, 0).EntireRow.Insert xlDown

With targetSheet.Range(Cells(findfirst.Row - 2, 1), Cells(findfirst.Row - 2, 14))
    .Merge
    .HorizontalAlignment = xlCenter
    .Interior.ColorIndex = 27
    .Font.Bold = 1
    .Font.Size = 18
    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    .Value = currentvalue
End With
Range("N1").Offset(1, 0).Value = Environ("Username")
End Sub

I hope that I have clearet out good and hope that some one can help me - Thank you beforehand :)

Answer 1

I'lltry something like this (using a loop to find 1.Altan 250):

Sub test1()

Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet

Dim fr, lr, nlr, llr As Long

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3")
Set targetSheet = wb.Worksheets(sourceCell.Text)

targetSheet.Range("A1").Value = "1.Altan 150"
targetSheet.Range("A1").Font.Bold = 1
targetSheet.Range("A1").Font.Size = 16
targetSheet.Range("A1:K1").Interior.ColorIndex = 27
targetSheet.Range("A3").Value = "1.Altan 250"
targetSheet.Range("A3").Font.Bold = 1
targetSheet.Range("A3").Font.Size = 16
targetSheet.Range("A3:K3").Interior.ColorIndex = 27

If ws.Range("H3").Value = 150 Then

Do Until targetSheet.Cells(t, 1).Value = "1.Altan 250"
lr = t - 1
t = t + 1
Loop

ws.Rows("1:10").Copy
targetSheet.Rows(lr & ":" & lr).Insert Shift:=xlDown

ElseIf ws.Range("H3").Value = 250 Then

nlr = targetSheet.Range("A" & 100000).End(xlUp).Row

ws.Rows("1:10").Copy
targetSheet.Rows(nlr & ":" & nlr).Insert Shift:=xlDown

End If

targetSheet.Range("A1:K1").Merge

llr = targetSheet.Range("A" & 100000).End(xlUp).Row
targetSheet.Range("A" & llr & ":K" & llr).Merge

targetSheet.Range("N1").Offset(1, 0).Value = Environ("Username")

End Sub