[英]VBA, New Sheet, Formating Cells
我有以下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
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
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.