vba code to copy all cells in a variable range

[andycreber]

Hi all

I have the following code in bold are copying cells that return data in formula after cell I4, but it is copying cells with a formula in it even if the formula is not returning any data, so visually the cells appear to be blank. IE my has to go down to 25 rows but in various cases the copied data may only apply to 5 rows.

It there a way to only copy the returned data in the formula? IE 5 rows without removing the formulas on the source sheet for the blank data

Reason being when I paste special values in the "Dump" sheet it is not finding the last true blank cell, its finding the whole copied range IE 20 rows so when this happens with multiple sheets there are blank rows in my data that cannot be sorted to align the rows.

All help would be greatly appreciated

thanks MR Excel helpers


Sheets("FL").Select
Range("I4").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Dump").Select
Range("B5000").End(xlUp).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[andycreber]

sorry, its been a long day

there are no blank cells in columns B&C that don't need removing

cheers

 

[MARK858]

Try running the code below

Sub DelBC()
    On Error Resume Next
    Sheets("Dump").Range("B:C").SpecialCells(4).Delete xlUp
    On Error GoTo 0
End Sub

 

[andycreber]

that brought it into line

THANK YOU

how do i put it all together? bearing in mind I have to add more of the original codes for the next 20 sheets.

thanks mate

 

[MARK858]

that brought it into line

THANK YOU

how do i put it all together? bearing in mind I have to add more of the original codes for the next 20 sheets.

thanks mate

Depends if you have any blank cells in the other columns that can't be removed.

 

[andycreber]

i don't have any blank cells in any other columns that i need to use

I am only bringing in data for columns A,B,C,F & G

column E has a formula in it

so i think its ok

 

[MARK858]

so i think its ok

If you only think it is ok make sure that you test thoroughly on a copy of your workbook before using on the actual workbook as you are deleting cells (and there is no undo stack).
Other than that just run or call the macro below after doing all your copies.

Btw, if you are doing exactly the same actions with your copy code on all the worksheets then you should look at looping through the worksheets rather than writing code for each, but that is another question and there are plenty of examples online.

Sub Trimit2()
    Dim myCell As Range, myRng As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set myRng = Sheets("Dump").Cells

    With myRng
        .Replace What:=Chr(160), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13) & Chr(10), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(21), Replacement:=Chr(32), LookAt:=xlPart

        .Replace What:=Chr(8), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(9), Replacement:=Chr(32), LookAt:=xlPart
    End With

    On Error Resume Next
    For Each myCell In Intersect(myRng, _
                                 myRng.SpecialCells(xlConstants, xlTextValues))
        myCell.Value = Application.Trim(myCell.Value)
    On Error GoTo 0
    Next myCell

    On Error Resume Next
    Sheets("Dump").Cells.SpecialCells(4).Delete xlUp
    On Error GoTo 0

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

 

[andycreber]

If you only think it is ok make sure that you test thoroughly on a copy of your workbook before using on the actual workbook as you are deleting cells (and there is no undo stack).
Other than that just run or call the macro below after doing all your copies.

Btw, if you are doing exactly the same actions with your copy code on all the worksheets then you should look at looping through the worksheets rather than writing code for each, but that is another question and there are plenty of examples online.

Sub Trimit2()
    Dim myCell As Range, myRng As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set myRng = Sheets("Dump").Cells

    With myRng
        .Replace What:=Chr(160), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13) & Chr(10), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(21), Replacement:=Chr(32), LookAt:=xlPart

        .Replace What:=Chr(8), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(9), Replacement:=Chr(32), LookAt:=xlPart
    End With

    On Error Resume Next
    For Each myCell In Intersect(myRng, _
                                 myRng.SpecialCells(xlConstants, xlTextValues))
        myCell.Value = Application.Trim(myCell.Value)
    On Error GoTo 0
    Next myCell

    On Error Resume Next
    Sheets("Dump").Cells.SpecialCells(4).Delete xlUp
    On Error GoTo 0

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

I put the code at the bottom of my code, ran it and it did not delete the blank cells. Do I need to put the =isblank formula bank in? As I took it out? thanks

 

[MARK858]

It shouldn't make any difference but what happens with the below ran separately?

Sub Trimit2b()
    Dim myCell As Range, myRng As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set myRng = Sheets("Dump").Cells

    With myRng
        .Replace What:=Chr(160), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13) & Chr(10), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(21), Replacement:=Chr(32), LookAt:=xlPart

        .Replace What:=Chr(8), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(9), Replacement:=Chr(32), LookAt:=xlPart
    End With

    On Error Resume Next
    For Each myCell In Intersect(myRng, _
                                 myRng.SpecialCells(xlConstants, xlTextValues))
        myCell.Value = Application.Trim(myCell.Value)
    Next myCell
    On Error GoTo 0
    

    On Error Resume Next
    Sheets("Dump").Cells.SpecialCells(4).Delete xlUp
    On Error GoTo 0

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

 

[andycreber]

It shouldn't make any difference but what happens with the below ran separately?

Sub Trimit2b()
    Dim myCell As Range, myRng As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set myRng = Sheets("Dump").Cells

    With myRng
        .Replace What:=Chr(160), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13) & Chr(10), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(13), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(21), Replacement:=Chr(32), LookAt:=xlPart

        .Replace What:=Chr(8), Replacement:=Chr(32), LookAt:=xlPart
        .Replace What:=Chr(9), Replacement:=Chr(32), LookAt:=xlPart
    End With

    On Error Resume Next
    For Each myCell In Intersect(myRng, _
                                 myRng.SpecialCells(xlConstants, xlTextValues))
        myCell.Value = Application.Trim(myCell.Value)
    Next myCell
    On Error GoTo 0
    

    On Error Resume Next
    Sheets("Dump").Cells.SpecialCells(4).Delete xlUp
    On Error GoTo 0

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

Nothing happend !

 

[andycreber]

I ran this code before and after my other code and nothing happened. Sorry about this, did I do something wrong in this? Thanks for your constant help.