我试图制作一张新广告,其中只有广告客户想要根据主要联系表进行广告宣传。
我的工作表设置如下:
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
答案 0 :(得分:1)
添加并运行此宏:
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
答案 1 :(得分:0)
下面的代码将检查工作表名称“Adversting”,否则会创建一个新的。它将复制自动过滤器值(广告栏中的“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
答案 2 :(得分:0)
我希望您知道如何打开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