Макрос по сбору информации с рабочих листов на итоговый...

[TimeStopper]

Есть макрос, который копирует на лист "Сравнение" столбцы F с рабочих листов 1...n.
Мне бы этот макрос усовершенствовать чуть чуть, что бы дополнительно на этот лист копировался бы и порядковый номер строки. Он находится в столбце А, в строках 3,5,7 итд...
Помогите пожалуйста...товарищи программисты ) товарищам строителям )

[Watcher_1]

Так пойдет?

Sub GetColumns()
    Dim lRow As Long
    
    Application.ScreenUpdating = False
        
    Set compSht = ActiveWorkbook.Sheets("Сравнение")
    compSht.Columns("A:L").Clear
    For Each Sh In Sheets
        k = k + 1
        If IsNumeric(Sh.Name) Then
            compSht.Cells(2, k) = Sh.Name
            lRow = Sheets(Sh.Name).Cells(Rows.Count, 6).End(xlUp).Row + 1
            i = 3
            Do
                DoEvents
                
                compSht.Cells(i, k) = Sheets(Sh.Name).Range("F" & i)
                compSht.Cells(i, k).HorizontalAlignment = xlLeft
                compSht.Cells(i + 1, k) = Sheets(Sh.Name).Range("A" & i)
                compSht.Cells(i, k).HorizontalAlignment = xlRight
                i = i + 2
                If Sheets(Sh.Name).Range("A" & i) = "" Then Exit Do
            Loop
            
        End If
    Next
        
    Application.ScreenUpdating = True
End Sub

[TimeStopper]

Вообще это то, что надо
...вот только по 12 столбцу - там с 804 номера прерывается макрос. Это связано с пустыми ячейками видимо, но у меня эти пустые ячейки - необходимость...
И если бы можно было оформить границы ячеек, как на примере...то было бы вообще супер...читать сложно очень!

[Watcher_1]

Вот

Sub GetColumns()
    Dim lRow As Long
    
    Application.ScreenUpdating = False
        
    Set compSht = ActiveWorkbook.Sheets("Сравнение")
    compSht.Columns("A:L").Clear
    For Each Sh In Sheets
        k = k + 1
        If IsNumeric(Sh.Name) Then
            compSht.Cells(2, k) = Sh.Name
            lRow = Sheets(Sh.Name).Cells(Rows.Count, 6).End(xlUp).Row + 1
            i = 3
            Do
                DoEvents
                
                compSht.Cells(i, k) = Sheets(Sh.Name).Range("F" & i)
                compSht.Cells(i, k).HorizontalAlignment = xlLeft
                compSht.Cells(i + 1, k) = Sheets(Sh.Name).Range("A" & i)
                compSht.Range(compSht.Cells(i, k), compSht.Cells(i + 1, k)).Interior.Color = 16764057
                For xxx = 7 To 10
                    compSht.Range(compSht.Cells(i, k), compSht.Cells(i + 1, k)).Borders(xxx).LineStyle = xlContinuous
                Next
                i = i + 2
                If Sheets(Sh.Name).Range("B" & i) = "" Then Exit Do
            Loop
            
        End If
    Next
        
    Application.ScreenUpdating = True
End Sub

[TimeStopper]

Огромное спасибо! Всех благ вам! )

[staniiislav]

можно еще такой вариант:

Sub Extract_Unique2()
   Dim vItem, sh As Worksheet
   With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
   For Each sh In Sheets
    If ActiveSheet.Name <> sh.Name Then
      For Each vItem In sh.Range("F3", sh.Cells(Rows.Count, "F").End(xlUp)).Value
         If Not IsEmpty(vItem) Then .Item(Trim(vItem)) = .Item(Trim(vItem)) + 1  ' в массиве .Keys накопятся уникальные значения, а в .Items - их количество
      Next
    End If
   Next
      If .Count Then [N10].Resize(.Count).Value = Application.WorksheetFunction.Transpose(.Keys)
      If .Count Then [O10].Resize(.Count).Value = Application.WorksheetFunction.Transpose(.items)
   End With
End Sub

взято вот от сюда:
http://www.excel-vba.ru/chto-umeet-e...ge-1/#comments