VBA, новый лист, формирующие ячейки

Question

У меня есть следующий скрипт VBA, который выполняет расширенный фильтр и заполняет новый лист. Я хотел бы получить результаты в порядке на моем новом листе.

Так, например, результаты листа 1 будут заполнены в C2, лист 2 C3, лист 3 в C4. Но если лист 2 не имеет результатов, лист 3 будет заполняться на C3. Кто-нибудь знает о какой-нибудь работе? Мне нужно, чтобы результаты соответствовали листу. Может быть простая формула диапазона? VBA новичок здесь.

 Sub louis4() 


Dim wks As Excel.Worksheet 
Dim wksSummary As Excel.Worksheet 
'---------------------------------------------------------------------------------- 
'edited so it shows in the 3rd column row +1. Add the header and sheet name macro to this 

On Error Resume Next 
Set wksSummary = Excel.ActiveWorkbook.Worksheets("Unique data") 
On Error GoTo 0 

If wksSummary Is Nothing Then 
    Set wksSummary = Excel.ActiveWorkbook.Worksheets.Add 
    wksSummary.Name = "Unique data" 
End If 


'Iterate through all the worksheets, but skip [Summary] worksheet. 
For Each wks In Excel.ActiveWorkbook.Worksheets 

    With wksSummary 

     If wks.Name <> .Name Then 
      If Application.WorksheetFunction.CountA(wks.Range("C:C")) Then 
       Dim r As Range 

    ' Get the first cell of our destination range... 
     Set r = .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row + 1, 3) 

    ' Perform the unique copy... 
    If WorksheetFunction.CountA(wks.Range("C:C")) > 1 Then 
     wks.Range("C:C").AdvancedFilter xlFilterCopy, , r, True 
    End If 

    ' Remove the first cell at the destination range... 
    r.Delete xlShiftUp 
      End If 
     End If 

    End With 

    Next wks 



     'Headers and sheet names 
    Range("A1").Value = "File Name " 
    Range("B1").Value = "Sheet Name " 
    Range("C1").Value = "Column Name" 

    Dim intRow As Long: intRow = 2 

    For i = 1 To Sheets.Count 
If Sheets(i).Name <> ActiveSheet.Name Then 
    Cells(intRow, 2) = Sheets(i).Name 
    Cells(intRow, 1) = ActiveWorkbook.Name 
    intRow = intRow + 1 
End If 
    Next i 




    End Sub 

Answer 1

Sub louis4() 


    Dim wks As Excel.Worksheet 
    Dim wksSummary As Excel.Worksheet 
    Dim LastCellInColumn As Range 
    Dim NewLastCellInColumn as Range 

    On Error Resume Next 
    Set wksSummary = Excel.ActiveWorkbook.Worksheets("Unique data") 
    On Error GoTo 0 

    If wksSummary Is Nothing Then 
     Set wksSummary = Excel.ActiveWorkbook.Worksheets.Add 
     wksSummary.Name = "Unique data" 
    End If 


    With wksSummary 

     'Headers and sheet names 
     .Range("A1").Value = "File Name " 
     .Range("B1").Value = "Sheet Name " 
     .Range("C1").Value = "Column Name" 

     'Iterate through all the worksheets, but skip [Summary] worksheet. 
     For Each wks In Excel.ActiveWorkbook.Worksheets 

      If wks.Name <> .Name Then 

       ' Get the first cell of our destination range... 
       Set LastCellInColumn = .Cells(.Rows.Count, 3).End(xlUp).offset(1,0) 

       If Application.WorksheetFunction.CountA(wks.Range("C:C")) > 1 Then 

        wks.Range("C:C").AdvancedFilter xlFilterCopy, , LastCellInColumn, True 

        ' Remove the first cell at the destination range... 
        ' because it contains the header text from the source sheet 
        LastCellInColumn.Delete xlShiftUp 

       else 

        LastCellInColumn.value = "No data found 

       End If 

       Set NewLastCellInColumn = .Cells(.Rows.Count, 3).End(xlUp).offset(1,0) 

       .cells(LastCellInColumn.offset(-1,0), NewLastCellInColumn.offset(-1,0)).value = wks.Name 

       .cells(LastCellInColumn.offset(-2,0), NewLastCellInColumn.offset(-2,0)).value = ActiveWorkbook.Name 



      End If 

     Next wks 

    End With 


End Sub 

Answer 2

As per what we discussed in the comments, I believe you want this: 


Sub louis4() 


Dim wks As Excel.Worksheet 
Dim wksSummary As Excel.Worksheet 
'---------------------------------------------------------------------------------- 
'edited so it shows in the 3rd column row +1. Add the header and sheet name macro to this 

On Error Resume Next 
Set wksSummary = Excel.ActiveWorkbook.Worksheets("Unique data") 
On Error GoTo 0 

If wksSummary Is Nothing Then 
    Set wksSummary = Excel.ActiveWorkbook.Worksheets.Add 
    wksSummary.Name = "Unique data" 
End If 


'Iterate through all the worksheets, but skip [Summary] worksheet. 
For Each wks In Excel.ActiveWorkbook.Worksheets 

    With wksSummary 

     If wks.Name <> .Name Then 
      If Application.WorksheetFunction.CountA(wks.Range("C:C")) Then 
       Dim r As Range 

    ' Get the first cell of our destination range... 
     Set r = .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row + 1, 3) 

    ' Perform the unique copy... 
    If WorksheetFunction.CountA(wks.Range("C:C")) > 1 Then 
     wks.Range("C:C").AdvancedFilter xlFilterCopy, , r, True 
    else 
     r = "N/A" 
    End If 

    ' Remove the first cell at the destination range... 
    r.Delete xlShiftUp 
      End If 
     End If 

    End With 

    Next wks 



     'Headers and sheet names 
    Range("A1").Value = "File Name " 
    Range("B1").Value = "Sheet Name " 
    Range("C1").Value = "Column Name" 

    Dim intRow As Long: intRow = 2 

    For i = 1 To Sheets.Count 
If Sheets(i).Name <> ActiveSheet.Name Then 
    Cells(intRow, 2) = Sheets(i).Name 
    Cells(intRow, 1) = ActiveWorkbook.Name 
    intRow = intRow + 1 
End If 
    Next i 




    End Sub