Announcement

Collapse
No announcement yet.

Macro that deletes empty columns

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Macro that deletes empty columns



    I have the following macros that copies and pastes data into another worksheet and formats column A as "Text". I then run the second macro that deletes empty columns, however, it also deletes the leading zeros in a cell (except fo Column A). The only way around this is to format the cells with leading zeros as "Text" and all is well. However, this is a problem as the cells with leading zeros can appear in several places;
    Column A being the constant (and is already formatted by the first macro) and the rest could appear in the following - E,F, K,L, Q,R, W,X, AC,AD, AI,AJ, AO,AP, AU,AV, BA,BB, BG,BH, BM,BN, BS,BT, BY,BZ, CE,CF, CK,CL, CQ,CR, CW,CX, DC,DD, DI,DJ, DO,DP, DU,DV, EA,EB, EG,EH, EM,EN, ES, ET ! I tried throwing in a macro to format these columns prior to running the delete columns but having a cell formatted to "Text" that is empty stops the macro in its' tracks. Basically I do not want to have to format the data with leading zeros manually. Is there a way that the macro can deal with these cells (that are "General" formatted) without losing the leading zeros? Here are the two macros in use;

    Code:
    Sub Copy_and_format()
    '
    ' Copy_and_format Macro
    ' Copies from filtering tab pastes to output tab and formats cells in Column A with leading zeros as Text
    '
    
    Sheets("Output").Select
        Range("A1:EV202").Select
        Selection.NumberFormat = "General"
        Selection.ClearContents
        
     Sheets("Filtering").Select
    Range("B4:EV200").Select
        Selection.Copy
        Sheets("Output").Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            'Range("A1").Select
        Columns("A").Select
        Application.CutCopyMode = False
        Selection.NumberFormat = "@"
        
    End Sub
    And the other macro is

    Code:
    Sub Delete_Blanks()
    '
    ' Delete_Blanks Macro
    
        Dim Ws As Worksheet
        Dim Rng As Range, Cell As Range
        Dim ArrCodes
        Dim i As Long
            
        Set Ws = ActiveSheet
        On Error Resume Next
        Set Rng = Ws.UsedRange.SpecialCells(xlTextValues)
        If Rng Is Nothing Then
            Exit Sub
        End If
        On Error GoTo 0
        
        ArrCodes = Array(127, 129, 141, 143, 144, 157, 160)
        
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        For Each Cell In Rng
            'Use the CLEAN function to remove 32 non printing chracters (0 to 31)
            'Trim is for removing leading and trailing blanks
            Cell = Trim(WorksheetFunction.Clean(Cell))
            'Now remove character code 127, 129, 141, 143, 144, 157, 160
            For i = LBound(ArrCodes) To UBound(ArrCodes)
                Cell = Replace(Cell, Chr(ArrCodes(i)), "")
            Next i
        Next Cell
        
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        
        'Dim Ws As Worksheet
        Dim lr As Long
        Dim lc As Long
        'Dim i As Long
        'this code assumes there are no cells with just a space as the value, which could cause unexpected results
        Set Ws = Worksheets("Output")
        lc = Ws.Cells(1, Columns.Count).End(xlToLeft).Column    'find last column WITH data based on row1 contents
        For i = lc To 1 Step -1
            lr = Ws.Cells(Rows.Count, i).End(xlUp).Row    'find last row with data in the current column, returns 1 even if row 1 is empty
            'next line checks to see if the current column
            If WorksheetFunction.CountA(Ws.Range(Ws.Cells(1, i), Ws.Cells(lr, i))) = 0 Then
                Ws.Cells(1, i).EntireColumn.Delete
            End If
        Next i
    End Sub
    This is hopefully the last hurdle I have with this process.

    Many thanks in advance

    TP59
Working...
X