需要用于 Excel 的复杂 VBA 将多张工作表拆分为许多其他按列数据过滤的工作表

Question

好的，所以我有一个问题，我有 5 张工作表（一张是过滤器名称的列表），我需要根据分销商名称进行过滤，并在新工作簿中创建新工作表以分发给他们。所有源工作表数据都来自 SQL DB，我希望能够在每次需要发送报告时运行这个宏。自从我使用 VBA 以来已经有一段时间了，但我使用记录器记录了使用 MS Query 获取基础的步骤，但我错过了如何为所有工作表和分配器组合（总共 36 个）自动执行此操作。这是非常原始的开始

    '
' Sort Macro
'

'
    Sheets.Add After:=ActiveSheet
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array( _
        "ODBC;DSN=CNG_POS;UID=brobbin;Trusted_Connection=Yes;APP=Microsoft Office 2013;WSID=BROBBIN-1Q1Z8;DATABASE=CNG_POS;QueryLog_On=Yes;Mu" _
        ), Array("ltiSubnetFailover=Yes;")), Destination:=Range("$A$1")).QueryTable

        .CommandText = Array( _
        "SELECT ""Missing_ORDERS>POS_LOOKUP"".""Fiscal Quarter ID"", ""Missing_ORDERS>POS_LOOKUP"".""ERP End Customer Name"", ""Missing_ORDERS>POS_LOOKUP"".""POS End Customer Master Name"", ""Missing_ORDERS>POS_LOOKUP"".""Da" _
        , _
        "te Booked"", ""Missing_ORDERS>POS_LOOKUP"".""POS DID"", ""Missing_ORDERS>POS_LOOKUP"".""ERP Deal ID"", ""Missing_ORDERS>POS_LOOKUP"".""Claim Authorization Number"", ""Missing_ORDERS>POS_LOOKUP"".""Sales Order Number " _
        , _
        "Detail"", ""Missing_ORDERS>POS_LOOKUP"".""Bookings Base List"", ""Missing_ORDERS>POS_LOOKUP"".""Bookings Net"", ""Missing_ORDERS>POS_LOOKUP"".""Bookings Quantity"", ""Missing_ORDERS>POS_LOOKUP"".""S" _
        , _
        "ales Level 1"", ""Missing_ORDERS>POS_LOOKUP"".""Partner Type"", ""Missing_ORDERS>POS_LOOKUP"".""ERP Bill To Customer Name"", ""Missing_ORDERS>POS_LOOKUP"".""Order Status"", ""Missing_ORDERS>POS_LOOKUP"".""Line Creati" _
        , _
        "on Date"", ""Missing_ORDERS>POS_LOOKUP"".""Order Source"", ""Missing_ORDERS>POS_LOOKUP"".""POS DISTRIBUTOR NAME"", ""Missing_ORDERS>POS_LOOKUP"".""Product ID"", ""Missing_ORDERS>POS_LOOKUP"".""POS Transaction ID"", ""M" _
        , _
        "issing_ORDERS>POS_LOOKUP"".""POS Trans Date"", ""Missing_ORDERS>POS_LOOKUP"".""Disti to Reseller Sales Order Date"", ""Missing_ORDERS>POS_LOOKUP"".""Invoice Number"", ""Missing_ORDERS>POS_LOOKUP"".""POS Base List P" _
        , _
        "rice"", ""Missing_ORDERS>POS_LOOKUP"".""Net POS (Validated) - Global"", ""Missing_ORDERS>POS_LOOKUP"".""Discount %"", ""Missing_ORDERS>POS_LOOKUP"".""Parent line ID"", ""Missing_ORDERS>POS_LOOKUP"".""Line ID""" & Chr(13) & "" & Chr(10) & "FROM C" _
        , _
        "NG_POS.dbo.""Missing_ORDERS>POS_LOOKUP"" ""Missing_ORDERS>POS_LOOKUP""" & Chr(13) & "" & Chr(10) & "WHERE (""Missing_ORDERS>POS_LOOKUP"".""POS DISTRIBUTOR NAME"" Like 'Tech%')" _
        )
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

我还想将源表名称保留为工作表名称，或者创建一个新字符串以包含分销商名称。
任何关于如何做到这一点的想法都将不胜感激，因为手动进行几乎是不可能的，并且不需要使用 MS 查询，这只是我可以确保在复制工作表时分销商数据是分开的一种方法。 我正在使用 excel 2013

Answer 1

好的这是我想出的，但是我必须为每张纸制作几个版本。在完美世界中，我会将 Dim C 设置为 = 另一张纸上的值。现在，最后缺少的部分是将生成的工作表保存到新工作簿中。

Sub ERP_POS()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Dim bAF As Boolean
Set ws1 = Sheets("ERP_POS")
Set rng = Range("Database")
bAF = ws1.AutoFilterMode


'extract a list of Sales Reps
With ws1
    .Columns("P:P").Copy _
      Destination:=.Range("X1")
    .Columns("X:X").AdvancedFilter _
      Action:=xlFilterCopy, _
      CopyToRange:=.Range("Y1"), Unique:=True
    r = .Cells(Rows.Count, "Y").End(xlUp).Row
    .Columns("X:X").ClearContents

    'set up Criteria Area
    .Range("X1").Value = .Range("P1").Value

    For Each c In .Range("Y2:Y" & r)

      'add the rep name to the criteria area
      .Range("X2").Value = _
            "=""="" & " & Chr(34) & c.Value & Chr(34)

      'add new sheet (if required)
      'and run advanced filter
      If WksExists("ERP_POS" & " " & c.Value) Then
        Sheets("ERP_POS" & " " & c.Value).Cells.Clear
        rng.AdvancedFilter Action:=xlFilterCopy, _
         CriteriaRange:=.Range("X1:X2"), _
          CopyToRange:=Sheets("ERP_POS" & " " & c.Value).Range("A1"), _
           Unique:=False
      Else
        Set wsNew = Sheets.Add
        wsNew.Move After:=Worksheets(Worksheets.Count)
        wsNew.Name = "ERP_POS" & " " & c.Value
        rng.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("X1:X2"), _
            CopyToRange:=wsNew.Range("A1"), _
            Unique:=False
      End If
    Next

    .Select
    .Columns("Y:X").EntireColumn.Delete

    If bAF = True Then
        .Range("A1").AutoFilter
    End If

End With
End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function