VBA，新工作表，格式化单元格

Question

I have the follow VBA script that does an advanced filter and populates to a new sheet. I would like to get the results in order on my new sheet.

So for example Sheet 1 results would be populated in C2, Sheet 2 C3, Sheet 3 in C4. But if Sheet 2 has no results Sheet 3 will populate in C3 instead. Anyone know of any work-around? I need the results to be correspond with the sheet. Could be a simple range formula? VBA newbie here.

     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