Question

我这里有一份销售报告，其中包括日期范围内的所有销售人员。

我需要这个宏做的是与每个销售人员，将他们的销售移动到新工作簿，按他们的号码保存工作簿并关闭。

Here is what my data looks like and what i want the macro to do

我将包含一些尚未使用的代码，您可能觉得它们没有用，但它会让您了解我想要实现的目标

Public Function ReportSummaries()
 Dim row, col, origPersonsLastRow, origSalesLastRow, i As Integer
 Dim original As Workbook
 Dim cell As Range
 Dim vendorsSheet, RawDataSheet As Worksheet

Set original = Application.Workbooks("SalesReportRpt (7).xlsm")
Set vendorsSheet = original.Worksheets("Sales person")
Set RawDataSheet = original.Worksheets("Sheet1")

'Optimize Macro Speed
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
 Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
 If myPath = "" Then GoTo ResetSettings

i = 2
origPersonsLastRow = vendorsSheet.UsedRange.Rows.Count
origSalesLastRow = RawDataSheet.UsedRange.Rows.Count
'MsgBox origVeodorsLastRow
For j = 2 To origPersonsLastRow ' cell In vendorsSheet.Columns("A").Cells
    Set cell = vendorsSheet.Cells(j, 1)
    'Set y = Workbooks.Open(" path to destination book ")
    'If cell.Value = 108 Or cell.Value = 30 Then
     '   GoTo NextWB
    'End If
    Set wb = Workbooks.Add
    With wb
        Application.DisplayAlerts = False
        RawDataSheet.Range("A1:k1").Copy wb.Sheets("Sheet1").Cells(1, 1)
        For k = 2 To origSalesLastRow ' Each rawCell In 
RawDataSheet.Columns("E").Cells
            Set rawCell = RawDataSheet.Cells(k, 4)
            If cell.Value = rawCell.Value And rawCell.Value <> "" And 
 rawCell.Value <> 108 Then
                'MsgBox "Matches"
                rawCell.EntireRow.Copy wb.Sheets("Sheet1").Cells(i, 1)
                i = i + 1
            ElseIf i > 6 And cell.Value = "" Then
                'Call BIGreport
                'GoTo Done
            End If
        Next k
        If cell.Value <> "" Then
            wb.CheckCompatibility = False
            Do Until Application.CalculationState = xlDone: DoEvents: 
 Loop
            .SaveAs Filename:=myPath & cell.Value, FileFormat:=xlNormal, 
 CreateBackup:=False
            '.Activate
            'wb.Activate
            '.Sheets("Sheet1").Activate
            'Call BIGreport(wb)
            .Close SaveChanges:=True
        ElseIf i > 6 Then
          GoTo Done
        End If

    End With
NextWB:

    i = 6
Next j
ResetSettings:
'Reset Macro Optimization Settings
 Application.EnableEvents = True
 Application.DisplayAlerts = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True
Done:
 'Exit Sub
 'Call LoopAllExcelFilesInFolder
 End Function

Answer 1

以下是@ 0m3r提供的答案：

Option Explicit
Sub Move_Each_Agent_to_Sheet()
'   // Declare your Variables
    Dim Sht As Worksheet
    Dim Rng As Range
    Dim List As Collection
    Dim varValue As Variant
    Dim i As Long

'      // Set your Sheet name
   Set Sht = ActiveWorkbook.Sheets("Sheet1")

'      // set your auto-filter,  A6
  With Sht.Range("A6")
    .AutoFilter
  End With

'   // Set your agent Column range # (2) that you want to filter it
  Set Rng = Range(Sht.AutoFilter.Range.Columns(3).Address)

'   // Create a new Collection Object
  Set List = New Collection

'   // Fill Collection with Unique Values
   On Error Resume Next
   For i = 2 To Rng.Rows.Count
    List.Add Rng.Cells(i, 1), CStr(Rng.Cells(i, 1))
   Next i

'   // Start looping in through the collection Values
  For Each varValue In List
'       // Filter the Autofilter to macth the current Value
    Rng.AutoFilter Field:=3, Criteria1:=varValue

'       // Copy the AutoFiltered Range to new Workbook
    Sht.AutoFilter.Range.Copy
    Worksheets.Add.Paste
    ActiveSheet.Name = Left(varValue, 30)
    Cells.EntireColumn.AutoFit

'   // Loop back to get the next collection Value
   Next varValue

'   // Go back to main Sheet and removed filters
    Sht.AutoFilter.ShowAllData
    Sht.Activate
End Sub

这解决了我最大的问题，即提取不同的销售人员销售......

Answer 2

由于您使用Excel for Windows，请使用JET / ACE引擎并运行SQL查询，因为您基本上在主工作簿上运行WHERE子句。唯一的挑战是你必须打开两个记录集：一个用于所有不同的 Sales Per ID迭代，每次构建第二个记录集（应用If条件），将数据转储到工作表。使用此方法无法复制/粘贴或运行具有各种A1逻辑的单元格。

以下是在两种连接类型上测试的版本。确保在SQL行中实际更改 SheetName ，并将 Sales Per 调整为完整列名。甚至考虑将主数据从Sub RunSQL() Dim conn As Object, rsSales As Object, rsData As Object, cmd As Object Dim strConnection As String, strSales As String, strSQL As String Dim new_wb As Workbook Dim i As Integer Const adcmdText = 1, adInteger = 3, adParamInput = 1 Application.ScreenUpdating = False Set conn = CreateObject("ADODB.Connection") Set rsSales = CreateObject("ADODB.Recordset") Set rsData = CreateObject("ADODB.Recordset") ' CONNECTION STRINGS (TWO VERSIONS) strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _ & "DBQ=C:\Path\To\Master\Data\Workbook.xlsx;" ' strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _ ' & "Data Source=C:\Path\To\Master\Data\Workbook.xlsx';" _ ' & "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";" ' OPEN DB CONNECTION conn.Open strConnection strSQL = "SELECT * FROM [SheetName$] WHERE [Sales Per] = ?;" strSales = "SELECT DISTINCT [Sales Per] FROM [SheetName$]" rsSales.Open strSales, conn Do While Not rsSales.EOF ' SET CMD COMMAND AND SETTINGS Set cmd = CreateObject("ADODB.Command") With cmd .ActiveConnection = conn .CommandText = strSQL .CommandType = adcmdText .CommandTimeout = 15 End With ' BINDING PARAMETER cmd.Parameters.Append cmd.CreateParameter("salesParam", adInteger, adParamInput, , rsSales![Sales Per]) ' EXECUTING TO RECORDSET Set rsData = cmd.Execute ' OPEN NEW WORKBOOK Set new_wb = Workbooks.Add() ' OUTPUT DATA TO SHEET With new_wb.Worksheets("Sheet1") .Name = "DATA" ' COLUMN HEADERS For i = 1 To rsData.Fields.Count .Cells(1, i) = rsData.Fields(i - 1).Name Next i ' DATA ROWS .Range("A2").CopyFromRecordset rsData End With ' SAVE WORKBOOK new_wb.SaveAs "C:\Path\To\Output\Workbooks\SalesPer_" & rsSales![Sales Per] & ".xlsx", xlWorkbookDefault new_wb.Close True rsData.Close rsSales.MoveNext Loop Application.ScreenUpdating = True MsgBox "Successfully completed!", vbInformation ExitHandle: rsSales.Close: conn.Close Set rsSales = Nothing: Set rsData = Nothing Set cmd = Nothing: Set conn = Nothing Exit Sub End Sub开始移动到真正的表。另外，下面显示了如何在ADO中参数化准备好的SQL语句，这是在VBA等应用程序层运行SQL时的行业最佳实践！

{{1}}

毋庸置疑，请考虑将主工作簿保存在真实数据库中，并根据需要运行所有查询切片和切块。

Answer 3

要将销售额移至新工作簿，请按其编号保存并关闭，更改以下内容

Sht.AutoFilter.Range.Copy
Worksheets.Add.Paste
ActiveSheet.Name = Left(varValue, 30)
Cells.EntireColumn.AutoFit

用的

Sht.AutoFilter.Range.Copy
Workbooks.Add
ActiveSheet.Paste

Dim CurPath As String
CurPath = ActiveWorkbook.Path & "\"

ActiveWorkbook.SaveAs Filename:=CurPath & Left(ListValue, 30)
Cells.EntireColumn.AutoFit
ActiveWorkbook.Close savechanges:=True

vba由销售人员将数据行复制并粘贴到销售人员的新工作簿中

3 个答案: