[英]Create New Dynamic Sheet based on Column
我正在嘗試制作一個新表格,其中只有想要基於主要聯系表格做廣告的廣告商。
我的工作表是這樣設置的:
Customer Add1 Add2 City/State/Zip Mailed Phone Called Advertising
其中廣告欄是 Y 或 N。我想要做的是有一個新表,其中包含每個在其廣告欄中有 y 的廣告商。
如果工作表 1 在廣告列中包含 Y,我已經讓它在新工作表中顯示客戶,但我必須將公式向下拖動,然后為具有 Ns 而不是 Ys 的行留出大量空格。 我是 VBA 的新手,如果我必須這樣做,我什至不知道從哪里開始。
我試圖在一個單獨的工作表上跟蹤他們想要什么樣的廣告,這樣我的主工作表上就沒有更多的列並且把它弄得亂七八糟。 如果歸結為它,我想我可以編寫一個 C++ 程序來做到這一點,但我想將它保留在 excel 中。
我已經查看了此處的一些代碼,但我不知道如何將其操作為我需要的。
編輯這就是我現在為我工作的內容,我將兩個解決方案合二為一:
Sub AdvertisingFilter()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Wst
Dim rN As Long, c As Long, counter As Long
Set Wb = ThisWorkbook
If e("Advertising") = False Then
With Wb.Sheets
.Add().Name = "Advertising"
End With
End If
Set Ws = Wb.Worksheets("Advertising")
Set Wst = Wb.Worksheets("Customers")
Ws.Cells.Clear
counter = 2 'Assuming you have a Header in your second sheet
With Wst
rN = .Cells(.Rows.Count, 1).End(xlUp).Row 'find last row
For c = 2 To rN
If .Cells(c, 9).Value = "Y" Then 'Copy only if the value in column I is "Y"
.Rows(c).Columns(1).Copy
Ws.Rows(counter).Columns(1).PasteSpecial xlPasteValues
counter = counter + 1
End If
Next
End With
End Sub
Function e(n As String) As Boolean
Dim Wss As Worksheet
e = False
For Each Wss In Worksheets
If n = Wss.Name Then
e = True
Exit Function
End If
Next Wss
End Function
添加並運行這個宏:
Sub CreateAdSheet()
With Sheets("Main Contact").UsedRange
.AutoFilter 8, "Y" ' <~~ Assumed advertising is column 8 (H)
.Copy Sheets.Add().Cells(2, 1)
.AutoFilter
End With
End Sub
下面的代碼將檢查工作表名稱“廣告”,如果沒有,它將創建一個新的。 它將復制自動過濾器值(廣告列上的“Y”)並將其粘貼到廣告表中
Option Explicit
Sub Worksheetfilter()
Dim c As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim WsPaste As Worksheet
Dim Columnaddress As Long
Dim Rowaddress As Long
Dim Rng As Range
Dim Rngcopy As Range
Dim Countws As Long
'On Error Resume Next
Set Wb = ThisWorkbook
Set Ws = Wb.Worksheets("sheet1")
With Ws.UsedRange
Set c = .Find("Advertising", LookIn:=xlValues)
If Not c Is Nothing Then
Columnaddress = c.Column
Rowaddress = c.Row
End If
End With
Set Rng = Ws.Columns(Columnaddress)
Countws = WorksheetFunction.CountIf(Rng, "Y")
If Countws >= 1 Then
If e("Adversting") = False Then
With Wb.Sheets
.Add().Name = "Adversting"
End With
End If
Set WsPaste = Wb.Worksheets("Adversting")
WsPaste.Cells.Clear
Ws.AutoFilterMode = False
'Ws.Rows(Rowaddress).AutoFilter Field:=Columnaddress, Criteria1:="Y"
Ws.UsedRange.Rows(Rowaddress).AutoFilter Field:=Columnaddress, Criteria1:="Y"
Set Rngcopy = Ws.UsedRange.SpecialCells(xlCellTypeVisible)
Rngcopy.Copy
WsPaste.Cells(1, 1).PasteSpecial xlValues
Application.CutCopyMode = False
Application.CutCopyMode = True
Ws.AutoFilterMode = False
End If
End Sub
Function e(n As String) As Boolean
Dim Wss As Worksheet
e = False
For Each Wss In Worksheets
If n = Wss.Name Then
e = True
Exit Function
End If
Next Wss
End Function
我希望你知道如何打開 VBA 並插入一個新模塊。 將其粘貼到模塊中:
Sub test()
Dim ws As Worksheet
Dim rN As Long, c As Long, counter As Long
Set ws = Worksheets(2) 'Change the 2 to the index where the sheet is located, i.e. if it is located in 4th position,
'then change the 2 to 4
counter = 2 'Assuming you have a Header in your second sheet
With ActiveSheet
rN = .Cells(.Rows.Count, 1).End(xlUp).Row 'find last row
For c = 2 To rN
If .Cells(c, 8).Value = "Y" Then 'Copy only if the value in column H is "Y"
.Rows(c).EntireRow.Copy
ws.Rows(counter).EntireRow.PasteSpecial xlPasteValues
counter = counter + 1
End If
Next
End With
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.