VBA Excel - Code deletes extra column

This was the answer to a prior question.  It worked in the text provided, however, in a new spreadsheet it deletes too many columns.  The text is imported into excel from a plain text file.  I need the building field to include the building and room together. Example:  Hum 116.

The text file is attached


Sub specialmacro()
Dim rng As Range
Dim celle As Range
Dim str1 As String
Dim str2 As String
Dim rowe As Long
Dim i As Long
 
rowe = 1
str1 = "A"
str2 = "A"
 
With Sheets("Sheet1")
    Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
End With
 
rng.Cut Destination:=Range("A2")
Columns("A:A").Insert Shift:=xlToRight
 
rowe = 1
str1 = "B"
str2 = "B"
 
With Sheets("Sheet1")
    Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
End With
 
For Each celle In rng
    On Error Resume Next
    Select Case LCase(Left(celle.Value, WorksheetFunction.Find(" ", celle.Value, 1) - 1))
        Case Is = "events"
            celle.Rows.EntireRow.Delete
        Case Is = "page"
            celle.Rows.EntireRow.Delete
        Case Is = "building"
            celle.Offset(0, -1) = celle.Value
    End Select
Next celle
 
For Each celle In rng
    If celle = "" And celle.Offset(0, 1) <> "" Then
        celle = celle.Offset(-1, 0)
    End If
Next celle
 
For Each celle In rng
    On Error Resume Next
    Select Case LCase(Left(celle.Value, WorksheetFunction.Find(" ", celle.Value, 1) - 1))
        Case Is = "room"
            celle.Offset(0, -1) = celle.Offset(0, -1).End(xlUp)
    End Select
Next celle
 
For Each celle In rng
    If celle = "" And celle.Offset(0, 1) = "" And celle.Offset(0, 2) = "" Then
        celle.Rows.EntireRow.Delete
    End If
    If celle = celle.Offset(0, -1) Then
        celle.Rows.EntireRow.Delete
    End If
Next celle
 
rowe = 1
str1 = "B"
str2 = "B"
 
With Sheets("Sheet1")
    Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
End With
 
For Each celle In rng
    If celle = celle.Offset(0, -1) Then
        celle.Rows.EntireRow.Delete
    End If
Next celle
 
For i = Cells(65536, 3).End(xlUp).Row To 1 Step -1
    If Cells(i, 3) = "" Then
        Rows(i).EntireRow.Delete
    End If
Next i
 
rowe = 1
str1 = "A"
str2 = "A"
 
With Sheets("Sheet1")
    Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
End With
 
For Each celle In rng
    celle = Mid(celle, 9, 10) & " " & Mid(celle.Offset(0, 1), 6, 10)
Next celle
 
Columns(2).Delete
Columns(1).AutoFit
 
End Sub
Open in New Window

   
Start Free Trial