Print Page | Close Window

Delete Empty Excel columns (after label rows)

Printed From: Roger's Access Library
Category: Other Download Libraries
Forum Name: Long, Crystal
Forum Description: Access Basics is designed for those of you with a thirst to understand the fundamentals of Access with programming in mind ... whether you realize it or not.
URL: www.rogersaccesslibrary.com/forum/forum_posts.asp?TID=621
Printed Date: 20 Oct 2017 at 12:04pm


Topic: Delete Empty Excel columns (after label rows)
Posted By: Crystal Long
Subject: Delete Empty Excel columns (after label rows)
Date Posted: 05 May 2016 at 9:41am
Delete Columns in Excel that are Empty

Use this code to delete columns that are completely empty by sending a parameter of one (1) for the first data row.  The default is currently to assume there is a row of labels to skip in determining if there is data in the column.

This is also perfect to run from Access after writing the results of a query where you only want to see columns with information.


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




-------------
Warm Regards,
Crystal
Microsoft MVP
Remote Training & Programming
Let's Connect and Build Together

http://www.AccessMVP.com/strive4peace
http://YouTube.com/LearnAccessByCrystal
~have an awesome day ~



Print Page | Close Window