Ускорить обработку строки, с использованием InStr

[SAS888]

Ваш код выдает ошибки, может, я что-то не то делаю?

Это значит, что листы либо заполнены произвольным образом, либо вообще не заполнены, либо в UsedRange какого-либо листа не входит 1-я строка (1-й столбец). Т.е. не выполняются предполагаемые мной условия. Ну, тогда попробуйте воспользоваться кодом, который может работать с произвольно заполненными листами и с произвольным объединением ячеек:

Sub RangeClear()
    Dim ws As Worksheet, c As Range, r As Range, arrC(), arrR()
    For Each ws In Sheets
        Set c = ws.Range(ws.[A1], ws.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)): arrC = c.Value
        Set r = ws.Range(ws.[A1], ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)): arrR = r.Value
        ws.Cells.ClearContents: c.Value = arrC: r.Value = arrR
    Next
End Sub

Пример использования во вложении.

По поводу окрашивания добавленных ячеек: попробуйте вместо строки кода

If data(z + 1) <> "" And r <> 1 Then arr(r, c) = data(z + 1)

использовать

Dim rng As Range
If data(z + 1) <> "" And r <> 1 Then
    arr(r, c) = data(z + 1)
    If rng Is Nothing Then Set rng = .Cells(r, c) Else Set rng = Union(rng, .Cells(r, c))
End If

где для каждого листа будет формироваться диапазон ячеек rng, который подлежит окрашиванию. Для того, чтобы окрасить этот диапазон, например, в желтый цвет, в конце цикла по листам книги добавьте строку

rng.Interior.ColorIndex = 6

Сравните время выполнения макросов с окрашиванием ячеек и без него (я этого не делал).