I've got the following code for the attached worksheet. My problem lies at the end of the code where I'm trying to determine the length of characters in column A. I get a zero value after the last row with an actual value. Does anyone know what is causing this? I know I can change my code to:
Code
aLen = Range("A1").End(xlDown).Row - 1
but that bypasses the problem, rather than fix it.
By the way, if you run the code, make sure you only have the worksheet "1" in the workbook.
Code
Sub Test()
Application.ScreenUpdating = False
Cells.EntireColumn.AutoFit
'Delete foot symbol from distances
Columns("E:E").Replace What:="'", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'Sort & Copy Multipule pages
Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets("1").Copy After:=Sheets(1)
Sheets("1 (2)").Copy After:=Sheets(2)
Sheets("1 (3)").Copy After:=Sheets(3)
'Clean each page
Sheets("1 (2)").Select
Dim ws1 As Worksheet
Set ws1 = ActiveSheet
For i = ws1.Range("A65536").End(xlUp).Row To 2 Step -1
If ws1.Cells(i, 1) <> "TRENCH_TYPE" Then
ws1.Rows(i).Delete
End If
Next
Sheets("1 (3)").Select
Dim ws2 As Worksheet
Set ws2 = ActiveSheet
For i = ws2.Range("A65536").End(xlUp).Row To 2 Step -1
If ws2.Cells(i, 1) <> "TRENCH_TYPE_II" Then
ws2.Rows(i).Delete
End If
Next
Sheets("1 (4)").Select
Dim ws3 As Worksheet
Set ws3 = ActiveSheet
For i = ws3.Range("A65536").End(xlUp).Row To 2 Step -1
If ws3.Cells(i, 1) = "TRENCH_TYPE" Then
ws3.Rows(i).Delete
End If
Next
For i = ws3.Range("A65536").End(xlUp).Row To 2 Step -1
If ws3.Cells(i, 1) = "TRENCH_TYPE_II" Then
ws3.Rows(i).Delete
End If
Next
'Trench Type 1
Sheets("1 (2)").Select
Columns("F:G").Delete Shift:=xlToLeft
Columns("C:C").Delete Shift:=xlToLeft
Columns("A:A").Delete Shift:=xlToLeft
'Add Calculation for distance
Dim dLen As Long
dLen = Range("C2").End(xlDown).Row
Range("D2").FormulaR1C1 = "=RC[-3]*RC[-1]"
Range("D2", Cells(dLen, 4)).Formula = Range("D2").Formula
Columns("D:D").Copy
Columns("D:D").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("A:A").Delete Shift:=xlToLeft
Columns("C:C").Delete Shift:=xlToLeft
Rows("1:1").Delete Shift:=xlUp
'Create Overall Totals
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
"C:C"), Unique:=True
Dim cLen As Long
cLen = Range("C1").End(xlDown).Row
Range("D1").FormulaR1C1 = "=SUMIF(C[-3],C[-1],C[-2])"
Range("D1", Cells(cLen, 4)).Formula = Range("D1").Formula
Columns("D:D").Copy
Columns("D:D").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("A:B").Delete Shift:=xlToLeft
Range("D1").FormulaR1C1 = "I"
Range("D1", Cells(cLen, 4)).Formula = Range("D1").Formula
Range("A1").Select
'Trench Type 2
Sheets("1 (3)").Select
Columns("G:G").Delete Shift:=xlToLeft
Columns("C:C").Delete Shift:=xlToLeft
Columns("A:A").Delete Shift:=xlToLeft
'Erase "Type "
Columns("D:D").Replace What:="TYPE ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'Add Calculation for distance
Columns("D:D").Insert Shift:=xlToRight
Dim dLen2 As Long
dLen2 = Range("C1").End(xlDown).Row
Range("D2").FormulaR1C1 = "=RC[-3]*RC[-1]"
Range("D2", Cells(dLen2, 4)).Formula = Range("D2").Formula
Columns("D:D").Copy
Columns("D:D").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("A:A").Delete Shift:=xlToLeft
Columns("B:B").Delete Shift:=xlToLeft
Rows("1:1").Delete Shift:=xlUp
'Create Overall Totals
Range("D1").FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-1])"
Range("D1", Cells(dLen2, 4)).Formula = Range("D1").Formula
Columns("D:D").Copy
Columns("A:A").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("C:D").ClearContents
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
"C:C"), Unique:=True
Dim cLen2 As Long
cLen2 = Range("C1").End(xlDown).Row - 1
Range("D1").FormulaR1C1 = "=SUMIF(C[-3],C[-1],C[-2])"
Range("D1", Cells(cLen2, 4)).Formula = Range("D1").Formula
Columns("C:D").Copy
Columns("A:B").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("C:D").Delete Shift:=xlToLeft
Columns("A:A").Copy
Columns("D:D").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("A:A").Replace What:="I", Replacement:=""
Columns("D:D").Select
With Selection
.Replace What:="G", Replacement:=""
.Replace What:="P", Replacement:=""
.Replace What:="S", Replacement:=""
.Replace What:="T", Replacement:=""
.Replace What:="C", Replacement:=""
.Replace What:="L", Replacement:=""
.Replace What:="E", Replacement:=""
.Replace What:="A", Replacement:=""
.Replace What:="B", Replacement:=""
.Replace What:="D", Replacement:=""
End With
'Complie 2 & 3 together
If Sheets("1 (2)").Range("a" & Rows.Count).End(xlUp).Row + _
Sheets("1 (3)").Range("a" & Rows.Count).End(xlUp).Row > Rows.Count Then
MsgBox "Too Much Data to fit in One Sheet"
Exit Sub
End If
With Sheets("1 (3)")
.Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 4).Copy _
Sheets("1 (2)").Range("a" & Rows.Count).End(xlUp).Offset(1)
End With
Sheets("1 (2)").Select
Dim aLen As Long
aLen = Range("A1").End(xlDown).Row
Range("E1").FormulaR1C1 = "=LEN(RC[-4])"
Range("E1", Cells(aLen, 5)).Formula = Range("E1").Formula
Cells.HorizontalAlignment = xlCenter
End Sub