Sub runDeleteColumnsNoData() 'crystal 'object variable does not need to be defined when using from Excel 'done this way to show how it would be done from Access Dim oSht As Object 'Excel.Worksheet Set oSht = ActiveSheet Call DeleteColumnsNoData(oSht) Set oSht = Nothing End Sub
Function DeleteColumnsNoData(oSht As Excel.Worksheet _ , Optional pnRow1 As Long = 2 _ ) As Long 'strive4peace 160505 'delete columns that are empty except for possible data in label rows ' 'PARAMETERS ' oSht = worksheet object ' pnRow1 = first row to check. Set to 1 to delete completely empty columns ' 'RETURNS ' number of columns deleted On Error GoTo Proc_Err
Dim nRow2 As Long _ , nCol1 As Long _ , nCol2 As Long _ , nCol As Long _ , nNextRowData As Long _ , nCountColsDeleted As Long _ , sMsg As String DeleteColumnsNoData = 0 '------------------------------------ nCol1 = 1 'first column to check nCountColsDeleted = 0 With oSht nRow2 = .UsedRange.Rows.Count '.Cells(.Rows.Count, 1).End(xlUp).Row 'xlUp=-4162 nCol2 = .UsedRange.Columns.Count '.Cells(1, .Columns.Count).End(xlToLeft).Column 'xlToLeft=-4159 End With '---------------------------- if automating, comment this sMsg = "DELETE All Columns from " _ & GetColumnLetter(nCol1) & " to " & GetColumnLetter(nCol2) _ & " (" & nCol1 & " to " & nCol2 & ") " _ & " with no data in cells " _ & vbCrLf & "from Row " & pnRow1 & " to Row " & nRow2 & "?" _ & vbCrLf & vbCrLf & "If you want to be able to 'undo' then " _ & "save your workbook first" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "Yes to DELETE COLUMNS?") <> vbYes Then GoTo Proc_Exit End If '---------------------------- With oSht For nCol = nCol2 To nCol1 Step -1 If pnRow1 > 1 Or (pnRow1 = 1 And Not .Cells(pnRow1, nCol) <> "") Then nNextRowData = .Cells(pnRow1, nCol).End(xlDown).Row If nNextRowData > nRow2 Then .Columns(nCol).Delete nCountColsDeleted = nCountColsDeleted + 1 End If End If Next nCol End With DeleteColumnsNoData = nCountColsDeleted '---------------------------- if automating, comment this sMsg = nCountColsDeleted & " Columns Deleted" MsgBox sMsg, , "Done" '---------------------------- Proc_Exit: On Error Resume Next Set oSht = Nothing Exit Function Proc_Err: MsgBox Err.Description, , _ "ERROR " & Err.Number _ & " DeleteColumnsNoData"
Resume Proc_Exit Resume End Function
Function GetColumnLetter(pCol As Long) As String '130116 strive4peace If pCol <= 26 Then GetColumnLetter = Chr(pCol + 64) Else GetColumnLetter = Chr(Int((pCol - 1) / 26) + 64) _ & Chr(((pCol - 1) Mod 26) + 65) End If End Function
|