VBA Help Needed Copying from one sheet to another skipping blank values (containing formulas)

B

Bozso46

New Member
Joined
May 30, 2017
Messages
4
Hello Good People!

I cannot for the life of my figure this one out, been trying for 3 days straight now so your help would be much appreciated.

I have a piece of code that imports data from another workbook. Bit ugly at certain points but this bit works fine.

Code: 
Sub import()
    
    Dim OpenFileName As String
 Dim wb As Workbook
 'Select and Open workbook
 OpenFileName = Application.GetOpenFilename(",*.xlsm")
 If OpenFileName = "False" Then Exit Sub
 Set wb = Workbooks.Open(OpenFileName)
 
 'Clear data
 ThisWorkbook.Sheets("Quote Summary").Range("A5:CC1000").ClearContents
 
 'Get Dashboard data
 ThisWorkbook.Sheets("Dashboard").Range("L3").Value = wb.Sheets("P&L - IPCG2").Range("C15").Value
 ThisWorkbook.Sheets("Dashboard").Range("J4").Value = wb.Sheets("P&L - IPCG2").Range("C16").Value
 ThisWorkbook.Sheets("Dashboard").Range("J5").Value = wb.Sheets("Combined P&L").Range("C12").Value
 ThisWorkbook.Sheets("Dashboard").Range("J6").Value = wb.Sheets("P&L - IPCG2").Range("C12").Value
 ThisWorkbook.Sheets("Dashboard").Range("J8").Value = wb.Sheets("Combined P&L").Range("K11").Value
 ThisWorkbook.Sheets("Dashboard").Range("J9").Value = wb.Sheets("P&L - IPCG2").Range("I36") + wb.Sheets("P&L - IPCG2").Range("I37") + wb.Sheets("P&L - IPCG2").Range("I40") + wb.Sheets("P&L - IPCG2").Range("I41") + wb.Sheets("P&L - IPCG2").Range("I63") + wb.Sheets("P&L - IPCG2").Range("I64") + wb.Sheets("P&L - IPCG2").Range("I69") + wb.Sheets("P&L - IPCG2").Range("I70") + wb.Sheets("P&L - IPCG2").Range("I71") + wb.Sheets("P&L - IPCG2").Range("I72") + wb.Sheets("P&L - IPCG2").Range("I75") + wb.Sheets("P&L - IPCG2").Range("I76") + wb.Sheets("P&L - IPCG2").Range("I98") + wb.Sheets("P&L - IPCG2").Range("I99") + wb.Sheets("P&L - IPCG2").Range("I104") + wb.Sheets("P&L - IPCG2").Range("I105")
  
 'Get Quote Summary data
 ThisWorkbook.Sheets("Quote Summary").Range("A4:CD1000").Value = wb.Sheets("Quote Summary - IPCG2").Range("A15:CD1000").Value
 
 With ThisWorkbook.Sheets("Quote Summary").Range("A4:A1000")
    .Replace "Y", ""
    .Replace "#N/A", ""
    .SpecialCells(xlBlanks).EntireRow.Delete
 End With
   
   wb.Close SaveChanges:=False
 
 MsgBox ("done")
 
End Sub

Now I have 2 Sheets in the workbook called "Primary" and "Secondary" these have the same header and (can) have values under them in the range A4:G1000. What I want to do is merge the data from the two Sheets into a thrid one called "Combined". The way I tried to do this is first copy A4:G1000 from "Primary" to "Combined". So far so good.

Code: 
Sub CopyPrimarytoCombined()
Worksheets("Port").Range("A1") = Worksheets("MPLS Port").Range("A1:G3")
Worksheets("Port").Range("A4:G1000").Value = Worksheets("MPLS Port").Range("A4:G1000").Value

End Sub

Now comes the part that drives me crazy.
The sheet called "Secondary" contains formulas in the A4:G1000 range. These populate the rows if necessary, otherwise they return blank values.
I'm trying to copy the rows that have non-blank values in the sheet called "Secondary" (remember blanks have formulas) and paste them into the first blank row of the sheet called "Combined". (first blank because I've already imported rows from the "Primary" sheet).

I have tried a dozen codes already but not one of them worked so I won't bother pasting them here.
If any of you fine people have any suggestions for me I'd be eternally grateful.

Many thanks in advance!
 
Sort by date Sort by votes
I was thinking:

1)Determine last blank cell in "Combined" (lngLastRow)
2)Filter on non-blanks
3)Copy visible content to Combined

I'm assuming that the formulas that return blank, return blank for the entire row.

Code: 
Dim lngLastRow As Long

    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).ROW + 1

    ActiveSheet.Range("$A:$G").AutoFilter Field:=1, Criteria1:="<>"
    Range("$A2:$G" & Cells(Rows.Count, "A").End(xlUp).ROW).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
 
Upvote 0
BrianM said:
I was thinking:

1)Determine last blank cell in "Combined" (lngLastRow)
2)Filter on non-blanks
3)Copy visible content to Combined

I'm assuming that the formulas that return blank, return blank for the entire row.

Code: 
Dim lngLastRow As Long

    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).ROW + 1

    ActiveSheet.Range("$A:$G").AutoFilter Field:=1, Criteria1:="<>"
    Range("$A2:$G" & Cells(Rows.Count, "A").End(xlUp).ROW).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
Click to expand...

Hi Brian,

thank you very much for your answer, this does work!

Trouble was that my original code that copied the values from primary to combined copied all the functions so the secondary would end up after row 1000, but I could modify the primary code to make this work.

Other issue was Pirmary and Secondary Sheets will be hidden, but found a way to work around this as well, so now I have a working code with exactly what I needed.

You're my hero, thank you very much!!!
 
Upvote 0
There is one more 'bug' with the code. It's a minor incovernience but if anyone knows how to work around it I would want to build it in.

This is what my code now looks like (big thanks again to BrianM):

Code: 
Sub Mergedata()

'REMOVE AND ADD NEW COMBINED SHEET
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Sheets("Combined").Delete
    On Error GoTo 0
    Sheets.Add.Name = "Combined"
    Application.DisplayAlerts = True

'COPY HEADER
 Sheets("Primary").Range("A1:F3").Copy
 
 Worksheets("Combined").Activate
 
 With ActiveSheet.Range("A1")
 .PasteSpecial xlPasteColumnWidths
 .PasteSpecial xlPasteValues
 .PasteSpecial xlPasteFormats
 Rows("1:2").RowHeight = 15
 Rows("3:3").RowHeight = 45
 End With
 
 Range("A1:F2").Select
 With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
 End With
 
'COPY PRIMARY
Dim lngLastRow As Long
    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    Worksheets("Primary").Activate
    ActiveSheet.Range("$A3:$G1000").AutoFilter Field:=7, Criteria1:="KEEP"
    Range("$A4:$F" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
 
'COPY SECONDARY
    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    Worksheets("Secondary").Activate
    ActiveSheet.Range("$A3:$G1000").AutoFilter Field:=7, Criteria1:="KEEP"
    Range("$A4:$F" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
        
End Sub

What sometimes happens is that the Secondary Sheet doesn't contain any data. So when the macro filters there isn't anything to copy. In this case it will copy row 3 (A3:G3, which is a header) and paste it into the first available column in the Combined Sheet.

Is there any way around this? I was thinking of using something with IF/ELSE but nothing really comes to mind....

Cheers
 
Upvote 0
Added a check on Secondary tab to see if there were more than one row of data.

Code: 
Sub Mergedata()

'REMOVE AND ADD NEW COMBINED SHEET
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Sheets("Combined").Delete
    On Error GoTo 0
    Sheets.Add.Name = "Combined"
    Application.DisplayAlerts = True

'COPY HEADER
 Sheets("Primary").Range("A1:F3").Copy
 
 Worksheets("Combined").Activate
 
 With ActiveSheet.Range("A1")
 .PasteSpecial xlPasteColumnWidths
 .PasteSpecial xlPasteValues
 .PasteSpecial xlPasteFormats
 Rows("1:2").RowHeight = 15
 Rows("3:3").RowHeight = 45
 End With
 
 Range("A1:F2").Select
 With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
 End With
 
'COPY PRIMARY
Dim lngLastRow As Long
    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).ROW + 1
    
    Worksheets("Primary").Activate
    ActiveSheet.Range("$A3:$G1000").AutoFilter Field:=7, Criteria1:="KEEP"
    Range("$A4:$F" & Cells(Rows.Count, "A").End(xlUp).ROW).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
 
'COPY SECONDARY

    lngLastRow = Sheets("Secondary").Cells(Rows.Count, "A").End(xlUp).ROW'<---------------Here
    
        If lngLastRow > 1 Then'<--------------Here
    
    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).ROW + 1
    
    Worksheets("Secondary").Activate
    ActiveSheet.Range("$A3:$G1000").AutoFilter Field:=7, Criteria1:="KEEP"
    Range("$A4:$F" & Cells(Rows.Count, "A").End(xlUp).ROW).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
        
        Else
        End If
        
End Sub
 
Upvote 0
BrianM said:
Added a check on Secondary tab to see if there were more than one row of data.

Code: 
Sub Mergedata()

'REMOVE AND ADD NEW COMBINED SHEET
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Sheets("Combined").Delete
    On Error GoTo 0
    Sheets.Add.Name = "Combined"
    Application.DisplayAlerts = True

'COPY HEADER
 Sheets("Primary").Range("A1:F3").Copy
 
 Worksheets("Combined").Activate
 
 With ActiveSheet.Range("A1")
 .PasteSpecial xlPasteColumnWidths
 .PasteSpecial xlPasteValues
 .PasteSpecial xlPasteFormats
 Rows("1:2").RowHeight = 15
 Rows("3:3").RowHeight = 45
 End With
 
 Range("A1:F2").Select
 With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
 End With
 
'COPY PRIMARY
Dim lngLastRow As Long
    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).ROW + 1
    
    Worksheets("Primary").Activate
    ActiveSheet.Range("$A3:$G1000").AutoFilter Field:=7, Criteria1:="KEEP"
    Range("$A4:$F" & Cells(Rows.Count, "A").End(xlUp).ROW).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
 
'COPY SECONDARY

    lngLastRow = Sheets("Secondary").Cells(Rows.Count, "A").End(xlUp).ROW'<---------------Here
    
        If lngLastRow > 1 Then'<--------------Here
    
    lngLastRow = Sheets("Combined").Cells(Rows.Count, "A").End(xlUp).ROW + 1
    
    Worksheets("Secondary").Activate
    ActiveSheet.Range("$A3:$G1000").AutoFilter Field:=7, Criteria1:="KEEP"
    Range("$A4:$F" & Cells(Rows.Count, "A").End(xlUp).ROW).SpecialCells(xlCellTypeVisible).Copy _
        Sheets("Combined").Range("A" & lngLastRow)
        
        Else
        End If
        
End Sub
Click to expand...

Apologies for the late reply, this fixed it for me like a dream. Only thing I had to change was If
Code: 
lngLastRow > 1
to
Code: 
[If lngLastRow > 4/CODE] as otherwise I think it counted the header as data.

Many thanks again BrianM
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Subscript out of range when copying values to another sheet
Replies
9
Views
329
ipbr21054
I
G
  • Question Question
Workbook formulas copied with Sheet references in new Workbook
Replies
0
Views
561
GK039
G
A
  • Solved
VBA Help!
Replies
2
Views
556
AusNewb
A
R
  • Solved
Combine all sheets into one - need help with existing code
Replies
7
Views
585
dmt32
D
N
  • Question Question
VBA - copy from one workbook and paste special values to another workbook
Replies
9
Views
271
Nikijune
N

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