基于列创build新的dynamic表单

我正在尝试制作一个新的表格，其中只有想要根据主要联系表进行广告的广告客户。

我的工作表是这样设置的：

Customer Add1 Add2 City/State/Zip Mailed Phone Called Advertising 

广告专栏是Y还是N。我想要做的是制作一个新的工作表，其中包含每个在广告专栏中都有的广告客户。

如果工作表1在广告列中包含Y，我已经得到它在新工作表中显示客户，但是我必须将公式向下拖动，然后对于具有Ns而非Ys的行有大量的空白空间。 我是VBA的新手，甚至不知道从哪里开始，如果这是我将不得不这样做的。

我试图在单独的表格上跟踪他们想要的广告types，所以我在主表单上没有更多的列，并将其混乱起来。 如果它归结为它，我想我可以写一个C ++程序来做到这一点，但我想保持在Excel中。

我已经看了一些在这里的代码，但我不知道如何操纵它到我所需要的。

编辑这是我现在正在为我工​​作，我把两个解决scheme合并成一个：

 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 

Answer 1

添加并运行这个macros：

 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 

Answer 2

我希望你知道如何打开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, ie 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 

Answer 3

下面的代码将检查表名称“Adversting”，如果不是，它将创build一个新的。 它将复制自动filter值（广告栏上的“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