Delete partial column and shift left

wjt5026

New Member
Joined
Jan 18, 2010
Messages
3
Hey guys,

So this is my first VBA project I've ever done. But what I need is to go through about 50 worksheets and delete partially blank columns and shift the full columns to the left.

I pull this data from PDF files and it is causing this formatting error. However, it also sometimes pulls in arrows (">"), which makes deleting the columns based on if they're empty difficult. Also the cells these arrows are in change, as do which columns are empty.

I would like this file to go through each worksheet(starting at the 5th worksheet (the first 4 are all formatted correctly). And then delete the empty columns (including columns that are empty except for ">"s)

This is the code I've written so far. It works so far but it won't go through each worksheet.

Sub CycleWorkSheets()
Dim mySheet As Worksheet
Dim i As Long
For i = 5 To ThisWorkbook.Worksheets.Count
Set mySheet = ThisWorkbook.Worksheets(i)
DeleteEmptyShiftLeft
Next i
End Sub

Private Sub DeleteEmptyShiftLeft()
Dim rngMyCell As Range
DeleteArrows
For Each rngMyCell In Range("C1:P700")
If (rngMyCell.Value) = "" And (rngMyCell.Column > 2) Then
rngMyCell.Delete Shift:=xlToLeft
End If
Next rngMyCell
Format
End Sub

Private Sub DeleteArrows()
Dim mySheet As Worksheet
For Each Cell In [A1:S700]
If Cell.Value() = ">" Then Cell.ClearContents
Next Cell
End Sub

Thanks in advance for any help
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650
Untested

Code:
Sub CycleWorkSheets()
Dim mySheet As Worksheet
Dim i As Long
For i = 5 To ThisWorkbook.Worksheets.Count
Set mySheet = ThisWorkbook.Worksheets(i)
Call DeleteEmptyShiftLeft(i)
Next i
End Sub

Private Sub DeleteEmptyShiftLeft(i As Integer)
Dim rngMyCell As Range
Call DeleteArrows(i)
With Sheets(i)
    For Each rngMyCell In .Range("C1:P700")
        If (rngMyCell.Value) = "" And (rngMyCell.Column > 2) Then
            rngMyCell.Delete Shift:=xlToLeft
        End If
    Next rngMyCell
End With
End Sub

Private Sub DeleteArrows(i As Integer)
Dim mySheet As Worksheet
For Each Cell In Sheets(i).Range("A1:S700")
If Cell.Value() = ">" Then Cell.ClearContents
Next Cell
End Sub
 

wjt5026

New Member
Joined
Jan 18, 2010
Messages
3
Oh wow, sorry. I had tried to edit the code myself so that was one that was in progress. This is what I'm trying to fix (Tested this time).

Sub CycleWorkSheets()
Dim mySheet As Worksheet
Dim i As Long
For i = 5 To ThisWorkbook.Worksheets.Count
Set mySheet = ThisWorkbook.Worksheets(i)
DeleteEmptyShiftLeft
Next i
End Sub

Private Sub DeleteEmptyShiftLeft()
Dim rngMyCell As Range
DeleteArrows
For Each rngMyCell In Range("C1:P700")
If (rngMyCell.Value) = "" And (rngMyCell.Column > 2) Then
rngMyCell.Delete Shift:=xlToLeft
End If
Next rngMyCell
End Sub

Private Sub DeleteArrows()
Dim mySheet As Worksheet
For Each Cell In [A1:S700]
If Cell.Value() = ">" Then Cell.ClearContents
Next Cell
End Sub
 
Last edited:

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650
Perhaps

Code:
Dim mySheet As Worksheet

Sub CycleWorkSheets()
Dim i As Long
For i = 5 To ThisWorkbook.Worksheets.Count
    Set mySheet = ThisWorkbook.Worksheets(i)
    DeleteEmptyShiftLeft
Next i
End Sub

Private Sub DeleteEmptyShiftLeft()
Dim rngMyCell As Range
DeleteArrows
For Each rngMyCell In mySheet.Range("C1:P700")
    If rngMyCell.Value = "" And (rngMyCell.Column > 2) Then
        rngMyCell.Delete Shift:=xlToLeft
    End If
Next rngMyCell
End Sub

Private Sub DeleteArrows()
Dim cell As Range
For Each cell In mySheet.Range("A1:S700")
    If cell.Value = ">" Then cell.ClearContents
Next cell
End Sub
 

wjt5026

New Member
Joined
Jan 18, 2010
Messages
3
Wow, one line was throwing me off that much? Thanks a lot works like a charm.

Is there any way to make the code go faster perhaps? I know now I'm just being picky, and I understand that it's going through every cell.. but I was wondering if maybe there is a way.
 

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650
This may speed things up slightly

Code:
Dim mySheet As Worksheet

Sub CycleWorkSheets()
Dim i As Long
Application.ScreenUpdating = False
For i = 5 To ThisWorkbook.Worksheets.Count
    Set mySheet = ThisWorkbook.Worksheets(i)
    DeleteEmptyShiftLeft
Next i
Application.ScreenUpdating = True
End Sub

Private Sub DeleteEmptyShiftLeft()
Dim rngMyCell As Range
DeleteArrows
For Each rngMyCell In mySheet.Range("C1:P700")
    If rngMyCell.Value = "" And (rngMyCell.Column > 2) Then
        rngMyCell.Delete Shift:=xlToLeft
    End If
Next rngMyCell
End Sub

Private Sub DeleteArrows()
Dim cell As Range
For Each cell In mySheet.Range("A1:S700")
    If cell.Value = ">" Then cell.ClearContents
Next cell
End Sub
 

Forum statistics

Threads
1,136,339
Messages
5,675,199
Members
419,553
Latest member
hanahass

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
Top