Hi
Added bit to remove the extra rows. Have you managed to build an example file that replicates the problem of not actioning all the items?
Sub aaa()
'remove any blank rows between address and company
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1).Value = "Address: " And Len(Cells(i - 1, 1)) = 0 Then
Cells(i - 1, 1).EntireRow.Delete shift:=xlUp
End If
Next i
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastrow
If Cells(i + 1, 1).Value = "Address: " Then
Cells(i + 1, 1).EntireRow.Insert shift:=xlDown
Cells(i + 1, 1).Value = "Company Type"
CT = Right(Cells(i, 1).Value, 1)
If CT = "D" Then
Cells(i + 1, 2).Value = "Distributor"
Else
Cells(i + 1, 2).Value = "Manufacturer"
End If
Cells(i, 2).Value = Left(Cells(i, 1).Value, Len(Cells(i, 1).Value) - 2)
Cells(i, 1).Value = "CompanyName: "
i = i + 1
End If
If Cells(i, 1).Value = "Address: " Then
Cells(i + 1, 1).EntireRow.Insert shift:=xlDown
Cells(i + 1, 1).Value = "Address 2: "
Cells(i, 2).Value = Cells(i, 2).Value & " " & Cells(i, 3).Value
Cells(i + 1, 2).Value = Cells(i, 4).Value & " " & Cells(i, 5).Value
Cells(i, 3).Resize(1, 4).ClearContents
End If
If Cells(i, 1).Value = "Web: " Then
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
holder = ""
j = i + 1
Do Until Cells(j + 2, 1) = "Address: " Or j > lastrow
If Len(Cells(j, 1)) > 0 Then
holder = holder & " " & Cells(j, 1).Value
Cells(j, 1).ClearContents
End If
j = j + 1
Loop
Cells(i + 1, 1).Value = "Description: "
Cells(i + 1, 2).Value = holder
End If
Next i
End Sub
rylo
Bookmarks