Copy & Paste two ranges from one sheet and merge to a single range on another sheet.

[Edgarvelez]

Hi, I have been using the code and all is good but my requirement changed a little.
Using the same code is it possible to copy range C & D from Sh1.
and paste them them merged to range E of sheet Sh3. with a / in between them
Looking for this result
7"x228" 6063GP Billet / MEDUI4510992

    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
    Set sh1 = Sheets("DashBoard")
    Set sh2 = Sheets("Sheet1")
    Set sh3 = Sheets("BOL")
    sh1.Range("D8").Copy
    sh3.Range("B8").PasteSpecial xlPasteFormulas
    sh1.Range("D9").Copy
    sh3.Range("E8").PasteSpecial xlPasteFormulas
    sh1.Range("D10").Copy
    sh3.Range("F8").PasteSpecial xlPasteFormulas
    sh1.Range("C12").Copy
    sh3.Range("E12").PasteSpecial xlPasteFormulas
    sh1.Range("C13").Copy
    sh3.Range("E13").PasteSpecial xlPasteFormulas
    sh1.Range("C14").Copy
    sh3.Range("E14").PasteSpecial xlPasteFormulas
    sh1.Range("C15").Copy
    sh3.Range("E15").PasteSpecial xlPasteFormulas
    sh1.Range("C15").Select
    Application.CutCopyMode = False
    sh1.Range("A7").Select

    


  Dim lr As Long

  lr = sh2.Range("F" & Rows.Count).End(3).Row
  sh2.Range("F3:F" & lr).Copy
  sh3.Range("B23").PasteSpecial xlPasteValues
  
  lr = sh2.Range("G" & Rows.Count).End(3).Row
  sh2.Range("G3:G" & lr).Copy
  sh3.Range("C23").PasteSpecial xlPasteValues
  
  
  lr = sh2.Range("C" & Rows.Count).End(3).Row
  sh2.Range("C3:C" & lr).Copy
  sh3.Range("E23").PasteSpecial xlPasteValues

  lr = sh2.Range("H" & Rows.Count).End(3).Row
  sh2.Range("H3:H" & lr).Copy
  sh3.Range("F23").PasteSpecial xlPasteValues
  
  
  
  lr = sh2.Range("B" & Rows.Count).End(3).Row
  sh2.Range("B3:B" & lr).Copy
  sh3.Range("G23").PasteSpecial xlPasteValues

End Sub

 

[HighAndWilder]

Change this line

lngLastRow = Ws.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

to this Line

lngLastRow = Worksheets("BOL").Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

 

[Edgarvelez]

We are getting there.
I started at the end on E33 and added the lines downwards it added an extra line which says Description \ OCEAN B/l
This is the results

 

[Edgarvelez]

Hi I got some additional help with this crazy code and I really appreciate all of your help with this.
This is what the code looks like.

Dim sh2 As Worksheet, sh3 As Worksheet
Dim i As Long, rng As Range, c As Range
Dim dataArr
Set sh2 = Worksheets("Sheet1")
Set sh3 = Worksheets("BOL")
Set rng = sh2.Range("C5:C" & sh2.Cells(sh2.Rows.Count, 3).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
ReDim dataArr(1 To rng.SpecialCells(xlCellTypeVisible).Count)
i = 1
    For Each c In rng
        dataArr(i) = c.Value & " / " & c.Offset(, 1).Value
        i = i + 1
    Next c
sh3.Range("E23").Resize(UBound(dataArr)) = Application.Transpose(dataArr)
End Sub

Thanks for your help and patience.