I think I'm missing something very simple
 

I want to optimize this code by taking the Sub Parse and fold it into
an IF...THEN statement that will run for only certain spreadsheets
within a workbook. The workbook may contain up to 100 worksheets, not
all of the worksheets will need the Sub Parse run on them. How to I
make this code work Better? It works right now, but I want to optimize
it. Thanks in Advance.

Sub CompareSheets()
Compare Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Sub Parse(WorkSheet1 As Worksheet, WorkSheet2 As Worksheet)
Sheets("Sheet1").Select
Columns("A:A").Select
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True
Columns("A:A").Delete
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True
Columns("A:A").Delete
Sheets("Sheet3").Select
End Sub
Sub Compare(WorkSheet1 As Worksheet, WorkSheet2 As Worksheet)
Dim MyCell As Range
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Worksheet, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Comparing Sheets..."
Set rptWB = Worksheets.Add(, Sheet2, 1)
Call Parse(Worksheets("Sheet1"), Worksheets("Sheet2"))
With WorkSheet1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With WorkSheet2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC,
"0 %") & "..."
For r = 3 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = WorkSheet1.Cells(r, c).FormulaLocal
cf2 = WorkSheet2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 < cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = cf1 & " < " & cf2
End If
If cf1 = cf2 Then
Cells(r, c).Formula = cf1
End If
Next r
Next c
Application.StatusBar = "Creating Comparison..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
With Range(Cells(1, 1), Cells(2, maxC))
.Interior.ColorIndex = 4
End With
Range(Cells(1, 1), Cells(maxR, maxC)).Select
For Each MyCell In Selection
If MyCell.Value Like "*<*" Then
MyCell.Interior.ColorIndex = 22
End If
Next
Cells(1, 1).Select
Worksheets("Sheet1").Columns("A:Z").AutoFit
Worksheets("Sheet2").Columns("A:Z").AutoFit
Worksheets("Sheet3").Columns("A:Z").AutoFit
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different values!",
vbInformation, _
"Compare " & WorkSheet1.Name & " with " & WorkSheet2.Name
Sheets("Sheet3").Activate
End Sub

I think I'm missing something very simple
 

this should do it if you only need to NOT include a couple. More or few use
an array.
for each ws in worksheets
if ws.name<"name1" and ws.name<"name2" then
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Space:=True
end if
next ws

--
Don Guillett
SalesAid Software

"DanQAEngineer" wrote in message
oups.com...
I want to optimize this code by taking the Sub Parse and fold it into
an IF...THEN statement that will run for only certain spreadsheets
within a workbook. The workbook may contain up to 100 worksheets, not
all of the worksheets will need the Sub Parse run on them. How to I
make this code work Better? It works right now, but I want to optimize
it. Thanks in Advance.

Sub CompareSheets()
Compare Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Sub Parse(WorkSheet1 As Worksheet, WorkSheet2 As Worksheet)
Sheets("Sheet1").Select
Columns("A:A").Select
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True
Columns("A:A").Delete
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True
Columns("A:A").Delete
Sheets("Sheet3").Select
End Sub
Sub Compare(WorkSheet1 As Worksheet, WorkSheet2 As Worksheet)
Dim MyCell As Range
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Worksheet, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Comparing Sheets..."
Set rptWB = Worksheets.Add(, Sheet2, 1)
Call Parse(Worksheets("Sheet1"), Worksheets("Sheet2"))
With WorkSheet1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With WorkSheet2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC,
"0 %") & "..."
For r = 3 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = WorkSheet1.Cells(r, c).FormulaLocal
cf2 = WorkSheet2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 < cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = cf1 & " < " & cf2
End If
If cf1 = cf2 Then
Cells(r, c).Formula = cf1
End If
Next r
Next c
Application.StatusBar = "Creating Comparison..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
With Range(Cells(1, 1), Cells(2, maxC))
.Interior.ColorIndex = 4
End With
Range(Cells(1, 1), Cells(maxR, maxC)).Select
For Each MyCell In Selection
If MyCell.Value Like "*<*" Then
MyCell.Interior.ColorIndex = 22
End If
Next
Cells(1, 1).Select
Worksheets("Sheet1").Columns("A:Z").AutoFit
Worksheets("Sheet2").Columns("A:Z").AutoFit
Worksheets("Sheet3").Columns("A:Z").AutoFit
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different values!",
vbInformation, _
"Compare " & WorkSheet1.Name & " with " & WorkSheet2.Name
Sheets("Sheet3").Activate
End Sub

I think I'm missing something very simple
 

Finally, because I like portable script and can never leave well enough
alone:

Sub Parse()
For Each ws In Worksheets
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True
Next ws
Application.DisplayAlerts = True
i = 1
For Each ws In Worksheets
Sheets("Sheet" & i).Activate
Range(Cells(1, 1), Cells(2, 1)).Select
For Each MyCell In Selection
If MyCell.Value Like "" Then
Columns(1).Delete
End If
Next
i = i + 1
Next ws
End Sub

I think I'm missing something very simple
 

why not just put a line in the first loop? But, do you really want to delete
col A?

Sub Parse()
For Each ws In Worksheets
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True
if range("a1")="" or range("a2")="" then columns(1).delete
Next ws


--
Don Guillett
SalesAid Software

"DanQAEngineer" wrote in message
oups.com...
Finally, because I like portable script and can never leave well enough
alone:

Sub Parse()
For Each ws In Worksheets
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True
Next ws
Application.DisplayAlerts = True
i = 1
For Each ws In Worksheets
Sheets("Sheet" & i).Activate
Range(Cells(1, 1), Cells(2, 1)).Select
For Each MyCell In Selection
If MyCell.Value Like "" Then
Columns(1).Delete
End If
Next
i = i + 1
Next ws
End Sub

I think I'm missing something very simple
 

You might want to eliminate all the selections:

Public Sub Parse()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
ws.Columns(1).TextToColumns _
DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=True
Next ws
Application.DisplayAlerts = True
For Each ws In Worksheets
With ws.Range("A1:A2")
If Application.CountA(.Cells) < 2 Then _
.EntireColumn.Delete
End With
Next ws
End Sub


In article .com,
"DanQAEngineer" wrote:

Finally, because I like portable script and can never leave well enough
alone:

Sub Parse()
For Each ws In Worksheets
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True
Next ws
Application.DisplayAlerts = True
i = 1
For Each ws In Worksheets
Sheets("Sheet" & i).Activate
Range(Cells(1, 1), Cells(2, 1)).Select
For Each MyCell In Selection
If MyCell.Value Like "" Then
Columns(1).Delete
End If
Next
i = i + 1
Next ws
End Sub

I think I'm missing something very simple
 

Should be

If ws.Range("A1")="" Or ws.Range("A2")="" Then ws.Columns(1).Delete

or all deletions will depend on A1:A2 of the active sheet.

In article ,
"Don Guillett" wrote:

why not just put a line in the first loop? But, do you really want to delete
col A?

Sub Parse()
For Each ws In Worksheets
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True
if range("a1")="" or range("a2")="" then columns(1).delete
Next ws

I think I'm missing something very simple
 

Thanks for catching that JE. Could have used WITH

--
Don Guillett
SalesAid Software

"JE McGimpsey" wrote in message
...
Should be

If ws.Range("A1")="" Or ws.Range("A2")="" Then ws.Columns(1).Delete

or all deletions will depend on A1:A2 of the active sheet.

In article ,
"Don Guillett" wrote:

why not just put a line in the first loop? But, do you really want to
delete
col A?

Sub Parse()
For Each ws In Worksheets
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True
if range("a1")="" or range("a2")="" then columns(1).delete
Next ws