Delete partial column and shift left

[wjt5026]

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

 

[VoG]

Untested

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]

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

 

[VoG]

Perhaps

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]

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]

This may speed things up slightly

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