VBA copy only if specific values exists

[ryanrh]

Hi! I'm stuck creating a macro to copy a range containing formulas and then special paste just the created values into a new sheet.

I've run into a problem where the entire range is being copied but the "" values in the new sheet are being pasted and read as a value. So when I try to import the new sheet elsewhere the entire range is imported.

Is there a way to only copy the formula cells if there was an actual value not the formula result "" blank? Or possibly a different solution? Thank you!

VBA I'm using:

'Copy Range of Data'
  Worksheets("Sheet1").Range("P2:V3500").Copy
    
'PasteSpecial Values Only'
  Worksheets("Sheet2").Range("K2").PasteSpecial Paste:=xlPasteValues

Example of information in the cell range being copied:

 =IF(ROUND(L4,1)=0,"",ROUND(L4,1))

 

[JGordon11]

try

    With Worksheets("Sheet1").Range("P2:V3500")
        Worksheets("Sheet2").Range("K2").Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With

 

[ryanrh]

Thanks but MS Access still wants to import the full Excel range even if it's empty, well, appearing empty in Excel. Also, I think that code is reformating the date and text fields back to the default which I need to stay exactly how they appeared before the paste. For example, one field should stay as "MM/YY", another should be "MM/DD", and one should be text so numbers such as "002" stay that way.

Some of the formula cells that get value pasted into the next sheet with the macro look like:

=IF(F2="","",TEXT(F2,"mm/dd"))

I'll share the whole code I'm working on for reference. It's probably a mess but basically I'm trying to make a protected worksheet where data gets entered in one sheet, then a macro button is used to move the data into a new sheet in the correct format so the new sheet will be all set to import into Access. I have a button created in Excel to run the macro, and another button to clear the data in the range.

Copy/Paste Button Code:

Sub PasteSpecial_ValuesOnly()
'PURPOSE: Paste Values Only With PasteSpecial'
  
'Unprotect Sheet'
  Sheets("Sheet2").Unprotect Password:="12345"
  Sheets("Sheet1").Unprotect Password:="12345"
  
'Copy First Range of Data'
  Worksheets("Sheet1").Range("P2:V3500").Copy
    
'PasteSpecial Values Only'
  Worksheets("Sheet2").Range("K2").PasteSpecial Paste:=xlPasteValues 

With Worksheets("Sheet1").Range("P2:V3500")
     Worksheets("Sheet2").Range("K2").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

'Clear Clipboard'
  Application.CutCopyMode = False
  
'Copy Second Range of Data'
  Worksheets("Sheet1").Range("W2:AF3500").Copy

'PasteSpecial Values Only'
  Worksheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteValues
  
With Worksheets("Sheet1").Range("W2:AF3500")
     Worksheets("Sheet2").Range("A2").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

'Clear Clipboard'
  Application.CutCopyMode = False
  
'Protect Sheet'
    Sheets("Sheet2").Protect Password:="12345"
    Sheets("Sheet1").Protect Password:="12345"
  
End Sub

"Clear" Button Code:

Sub sbClearCells()
'PURPOSE: Clear cell contents user entered and clear everything created by paste macro'

'Clear cell data in user entered cells'
Worksheets("Sheet1").Range("B2:E2,F2:M3500").Cells.ClearContents

'Unprotect paste workheet'
Sheets("Sheet2").Unprotect Password:="12345"

'Clear the cell data on worksheet created by paste macro'
Worksheets("Sheet2").Range("A2:Q3500").Cells.Clear

'Protect paste worksheet'
Sheets("Sheet2").Protect Password:="12345"

End Sub

 

[JGordon11]

If you import data that includes some cells with absolutely nothing in them does access work as intended?

 

[ryanrh]

If you import data that includes some cells with absolutely nothing in them does access work as intended?

Kind of. It's importing into our database fine, but also importing all of the blank rows in the range, so 3500 rows each time, bogging it down when we try to pull reports. So I have to delete them in the Access tables.

 

[JGordon11]

I suggest changing the code to find the last row with data and then import only the range ending at that last row.

 

[ryanrh]

I suggest changing the code to find the last row with data and then import only the range ending at that last row.

How would I implement that? Right now I just use the External Data tab in Access, then "Import Excel Spreadsheet" wizard to import the spreadsheet and append the Access table to add the records.

It does show an option to import a named range instead but I'm not familiar with how to use that.

Maybe I could I add Excel VBA code to find the cells that aren't blank in the newly pasted worksheet after it runs, then move that data into a third worksheet to import? I'm not sure what code to use for that either and it's probably an unnecessary step too. ? This is trickier than I thought.

 

[ryanrh]

Ended up making an additional sheet to filter and copy cells with data only. (credit: vbasic2008 on SO)

Sub CopyFilterData()

    ' Source
    Const sName As String = "Sheet2"
    Const sFirst As String = "A1"
    ' Destination
    Const dName As String = "Sheet3"
    Const dFirst As String = "A1"
    Const dfField As Long = 1
    Const dfCriteria As String = "="
    ' Both
    Const Cols As String = "A:Q"
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
    
    Dim slCell As Range
    With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
        Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
    End With
    If slCell Is Nothing Then Exit Sub ' no data in column range
    
    Dim rCount As Long: rCount = slCell.Row - sfCell.Row + 1
    If rCount = 1 Then Exit Sub ' only headers
    
    Dim scrg As Range: Set scrg = sfCell.Resize(rCount) ' Criteria Column Range
    Dim srg As Range: Set srg = scrg.EntireRow.Columns(Cols) ' Table Range
    Dim cCount As Long: cCount = srg.Columns.Count
    
    Application.ScreenUpdating = False
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    If dws.AutoFilterMode Then dws.AutoFilterMode = False
    dws.UsedRange.Clear
    Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfcell.Resize(rCount, cCount) ' Table Range
    
    srg.Copy drg ' copy
    
    Dim ddrg As Range: Set ddrg = drg.Resize(rCount - 1).Offset(1) ' Data Range
    
    drg.AutoFilter dfField, dfCriteria
    
    Dim ddfrg As Range ' Data Filtered Range
    On Error Resume Next
        Set ddfrg = ddrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    dws.AutoFilterMode = False
    
    If Not ddfrg Is Nothing Then
        ddfrg.EntireRow.Delete ' delete 'empty' rows
    End If
    
    'drg.EntireColumn.AutoFit
    'wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data copied.", vbInformation, "Copy Filtered Data"

End Sub