Question

在这些论坛中提出的2个热门问题略有不同......

我正在尝试将Excel工作簿拆分为基于不同列值的多个工作簿（让我们称之为saleTeam1，saleTeam2，saleTeam3）。

但是，主题工作簿有多个工作表，每个工作表都报告不同销售团队的不同指标：工作表之间唯一的共同点是销售团队，在每个工作表的第一列上显示。

我将2个VBA宏用于其他不同的任务：

1）根据A列中的唯一值和

将目标工作表解析为多个工作表

2）拆分工作簿并为每个唯一的工作表创建新的工作簿。

尝试将两个功能集成在一起，但我觉得从头开始构建它可能更值得。但是，我无法围绕一个有效的解决方案。

    Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

'set split target column
vcol = 1

' set split target sheet
Set ws = Sheets("Sheet1")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:M1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Sub SplitWB()
Dim xlApp As Object
Dim wbSource As Object
Dim wbNew As Object
Dim ws As Worksheet
Dim strFileName As String

    ' change path and filename here
    strFileName = "C:\Users\username\Documents\split\split.xlsx"

    Set xlApp = CreateObject("Excel.Application")

    Set wbSource = xlApp.Workbooks.Open(strFileName)

    For Each ws In wbSource.Worksheets
         ws.Copy
         Set wbNew = xlApp.ActiveWorkbook
         wbNew.SaveAs wbSource.Path & xlApp.PathSeparator & ws.Name & ".xlsx"
         wbNew.Close
         Set wbNew = Nothing
    Next ws

    wbSource.Close SaveChanges:=False
    Set wbSource = Nothing

    xlApp.Quit
    Set xlApp = Nothing

End Sub

结论：尝试将6个团队数据制作成1个工作簿（包含5个不同列的工作表），分成6个工作簿（每个工作簿与原始工作簿相同的5个工作表），每个团队的数据分开

Answer 1

我不喜欢将您的两个功能分组的想法，我更喜欢首先让团队使用字典，然后为每个团队创建一个WB并使用Excel的过滤功能。试试这样：

case 
    when R1 = risk and R2 = risk then 2 
    when R1 = risk xor R2 = risk then 1
    else 0 
end 
as score

如何将基于列的多个工作表中的数据拆分为Excel中的多个工作簿？

1 个答案: