CopyPaste Macro to skip blank cells and zero values OR Delete Blank Cells and zero values

D

Daniel_15

New Member
Joined
Apr 8, 2015
Messages
29
Hi
I am trying to write a copypaste macro that will only paste non-blank or non-zero values (the CopyNonZeroValues macro). The “EXAMPLE_RANGE” the macro is referring to is a worksheet that has a bunch of formula driven outputs. If the formula returns a zero, I have it return/formatted as “”. Based on this I believe the macro is still taking those values. So I tried another macro to clean this up on the “upload” worksheet. However, instead of deleting rows that appear blank, it keeps them. When I test the “blank” cells in column which contains the pasted data I get varying answers. Testing the cell value with a 0=0 returns FALSE but a Len() test returns 0. So that is a bit confusing. There must be a carry over from the original copied data and formula.
Ultimately, I am trying to get one macro that will copypaste data into a new worksheet and not carry over blanks or zero values cells (compress the data so there are not any empty rows) and then write this data to a text file. I have tried the writing to a text file yet because I can’t seem to get by this first step.

Thank you for your consideration.

Here is the code.

Sub CopyNonZeroValues()
' Defines variables
Dim cRange As Range
Set cRange = Range("EXAMPLE_RANGE")
Range("EXAMPLE_RANGE").Copy
Sheets("upload").Range("D4").PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True

End Sub

Sub DeleteAllEmptyRows()
Dim SourceRange As Range
Dim EntireRow As Range

Set SourceRange = Application.Sheets("upload").Range("D1:D600")

If Not (SourceRange Is Nothing) Then
Application.ScreenUpdating = False

For I = SourceRange.Rows.Count To 1 Step -1
Set EntireRow = SourceRange.Cells(I, 1).EntireRow
If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
EntireRow.Delete
End If
Next

Application.ScreenUpdating = True
End If

End Sub
 
Sort by date Sort by votes
You're welcome, glad to help, & thanks for the feedback.:)
 
Upvote 0

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Hi Akuini,

I have a question. I need the write to file to put quotation marks around all text (excluding lines that start with // or numbers). Please see example below.

"//$DDL 2012.1 'Not this line for example because of the "//" or any other line with "//"
//NewSeries
//Issuer
MUD 'Need quotes on this line and others like it
//IssuerTitle
Harris Co MUD # 105 'Need quotes on this line
//NewSeries
//Issuer
MUD
//IssuerTitle
Harris Co MUD # 105
//Series
19A_WS
//SeriesTitle
U/L Tax Bds Ser 2019A
//SeriesStatus
Act
//Dated
09/01/2019 'No quotes here for example because it is a number
//Deliv
09/01/2019
//FirstInt
03/01/2020
//IntFreq
6
//Basis
30/360
//BeginBondDescription
//Name
SER
//Title
Serial Bonds
//Options
Serial
//BeginMaturityTable 25
03/01/2024,110000,0.02,0.0145,, 'No quotes on these lines either for example
03/01/2025,200000,0.02,0.015,,
03/01/2026,200000,0.02,0.0155,,
03/01/2027,250000,0.02,0.017,,
03/01/2028,275000,0.02,0.018,,
03/01/2029,300000,0.0225,0.019,,
03/01/2030,300000,0.0225,0.02,,
03/01/2031,300000,0.0225,0.0205,,
03/01/2032,325000,0.0225,0.0215,,
03/01/2033,350000,0.0225,0.0225,,
03/01/2034,350000,0.02375,0.024,,
03/01/2035,350000,0.025,0.024,,
03/01/2036,375000,0.025,0.025,,
03/01/2037,375000,0.025,0.0255,,
03/01/2038,400000,0.025,0.0258,,
03/01/2039,425000,0.025,0.026,,
03/01/2040,425000,0.02625,0.028,,
03/01/2041,450000,0.02625,0.028,,
03/01/2042,450000,0.02625,0.028,,
03/01/2043,500000,0.02625,0.028,,
03/01/2044,525000,0.02625,0.028,,
03/01/2045,525000,0.0275,0.0282,,
03/01/2046,525000,0.0275,0.0283,,
03/01/2047,550000,0.0275,0.0284,,
03/01/2048,555000,0.0275,0.0285,,
//EndMaturityTable
//Series
19A_WS
//SeriesTitle
U/L Tax Bds Ser 2019A
//SeriesStatus
Act
//Dated
09/01/2019
//Deliv
09/01/2019
//FirstInt
03/01/2020
//IntFreq
6
//Basis
30/360
//BeginBondDescription
//Name
SER
//Title
Serial Bonds
//Options
Serial
//BeginMaturityTable 25
03/01/2024,110000,0.02,0.0145,,
03/01/2025,200000,0.02,0.015,,
03/01/2026,200000,0.02,0.0155,,
03/01/2027,250000,0.02,0.017,,
03/01/2028,275000,0.02,0.018,,
03/01/2029,300000,0.0225,0.019,,
03/01/2030,300000,0.0225,0.02,,
03/01/2031,300000,0.0225,0.0205,,
03/01/2032,325000,0.0225,0.0215,,
03/01/2033,350000,0.0225,0.0225,,
03/01/2034,350000,0.02375,0.024,,
03/01/2035,350000,0.025,0.024,,
03/01/2036,375000,0.025,0.025,,
03/01/2037,375000,0.025,0.0255,,
03/01/2038,400000,0.025,0.0258,,
03/01/2039,425000,0.025,0.026,,
03/01/2040,425000,0.02625,0.028,,
03/01/2041,450000,0.02625,0.028,,
03/01/2042,450000,0.02625,0.028,,
03/01/2043,500000,0.02625,0.028,,
03/01/2044,525000,0.02625,0.028,,
03/01/2045,525000,0.0275,0.0282,,
03/01/2046,525000,0.0275,0.0283,,
03/01/2047,550000,0.0275,0.0284,,
03/01/2048,555000,0.0275,0.0285,,
//EndMaturityTable
 
Upvote 0
here is the current code.

Sub Write_Directly_to_Text_File()
Dim strFile_Path As String
Dim obj As New DataObject
Dim tx As String
Range("EXAMPLE_RANGE").Copy
obj.GetFromClipboard
tx = obj.GetText
Application.CutCopyMode = False

tx = Replace(tx, vbLf & 0 & vbCr, "")
tx = Replace(tx, vbLf & vbCr, "")
strFile_Path = ThisWorkbook.Path & "\DDL Upload" & Format(Now, "mm_dd_yy h_mm AM/PM") & ".ddl"

Open strFile_Path For Append As #1
Write #1 , tx
Close #1
End Sub
 
Upvote 0
OK, try tyhis:
Note: if you're using Windows 8.1/Excel 2013 there's a bug you should know related to clipboard object. Read this article:
https://www.thespreadsheetguru.com/blog/2015/1/13/how-to-use-vba-code-to-copy-text-to-the-clipboard

And I'm indeed using Windows 8.1/Excel 2013, so when I run this code it will put 4 double quotes instead of 2 around the intended lines.
Let's see how it works on your side.


Code: 
[FONT=Lucida Console][COLOR=Royalblue]Sub[/COLOR] a1112370d()
    [COLOR=Royalblue]Dim[/COLOR] strFile_Path [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]
    [COLOR=Royalblue]Dim[/COLOR] obj [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]New[/COLOR] DataObject
    [COLOR=Royalblue]Dim[/COLOR] tx [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]

    Range([COLOR=Darkcyan]"A1:A20"[/COLOR]).Copy
    obj.GetFromClipboard
    tx = obj.GetText
    Application.CutCopyMode = False
    
        tx = Replace(tx, vbLf & [COLOR=Brown]0[/COLOR] & vbCr, [COLOR=Darkcyan]""[/COLOR])
        tx = Replace(tx, vbLf & vbCr, [COLOR=Darkcyan]""[/COLOR])
        
        ary = Split(tx, vbCrLf)
        [COLOR=Royalblue]For[/COLOR] i = [COLOR=Royalblue]LBound[/COLOR](ary) [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](ary)
            
            z = ary(i)
            [COLOR=Royalblue]If[/COLOR] Len(z) > [COLOR=Brown]0[/COLOR] [COLOR=Royalblue]Then[/COLOR]
                [COLOR=Royalblue]If[/COLOR] Left(z, [COLOR=Brown]2[/COLOR]) <> [COLOR=Darkcyan]"//"[/COLOR] [COLOR=Royalblue]And[/COLOR] [COLOR=Royalblue]Not[/COLOR] IsNumeric(Left(z, [COLOR=Brown]1[/COLOR])) [COLOR=Royalblue]Then[/COLOR]
                    ary(i) = Chr([COLOR=Brown]34[/COLOR]) & z & Chr([COLOR=Brown]34[/COLOR])
                [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
            [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
            
[I][COLOR=Dimgray]'            Debug.Print z[/COLOR][/I]
        [COLOR=Royalblue]Next[/COLOR]
        
        tx = Join(ary, vbCrLf)
        'Debug.Print tx
        strFile_Path = [COLOR=Darkcyan]"D:\zz\tezt2.txt"[/COLOR] [I][COLOR=Dimgray]'Change to suit[/COLOR][/I]

        Open strFile_Path [COLOR=Royalblue]For[/COLOR] Append [COLOR=Royalblue]As[/COLOR] #[COLOR=Brown]1[/COLOR]
        Write #[COLOR=Brown]1[/COLOR], tx
        Close #[COLOR=Brown]1[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]
 
Last edited:
Upvote 0
Ok, thank you for letting me know. I will read the article and give the code a try. Thanks again and have a great weekend.
 
Upvote 0
Ok, just replace this line:

Code: 
Write #1, tx

with this:

Code: 
Print #1, tx

And you still want to use your previous requirements (i.e removing the blank cell & cell with zero), right?
otherwise just remove this part:

Code: 
        tx = Replace(tx, vbLf & 0 & vbCr, "")
        tx = Replace(tx, vbLf & vbCr, "")
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
Macro for adding IF statements to the existing formula
Replies
1
Views
110
CephasOz
CephasOz
D
  • Question
Deleting cell data upon open based on cell value
Replies
2
Views
132
Darren_workforce
D
D
  • Solved
Excel VBA for Changing Tab Name & Return Blank Cell to Formula
Replies
5
Views
136
DjTRex2002
D
H
  • Solved
Macro to delete Zero and blank Rows
Replies
1
Views
366
Norie
Norie
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
336
howard
H

Forum statistics

Threads
1,214,788
Messages
6,121,603
Members
449,038
Latest member
Arbind kumar

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