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

我在这里是销售报告，其中包括date范围内的所有销售人员。

我需要这个macros是与每个销售人员，将他们的销售移动到新的工作簿，保存工作簿的数量，并closures。

这里是我的数据看起来像什么，我想要macros做什么

我将包括一些没有工作的代码，并且你可能找不到有用的代码，但它会给你一个想知道我即将完成的事情

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子句。 唯一的挑战是你必须打开两个logging集：一个用于遍历每个不同的Sales Per ID，每次构build将数据转储到工作表的第二个logging集（应用WHERE条件）。 没有复制/粘贴或运行与这种方法的各种If逻辑单元格。

以下是两种连接types的testing版本。 请确保实际更改SQL行中的SheetName ，并将“ Sales Per”调整为完整的列名称。 即使考虑将主数据移动到A1开始真正的表格。 另外，下面展示了如何在ADO中参数化一个准备好的SQL语句，在VBA这样的应用层上运行SQL时，这是一个行业最佳实践！

 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 

不用说，考虑将主工作簿保存在真正的数据库中，并根据需要运行所有查询来切片和切块。

Answer 3

要将销售移至新工作簿，请将其保存为编号并closures，然后更改以下内容

 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