将并排多列拆分成包含子文件夹工作簿

lele400024

核心需求：
1、按源数据Q列新建文件夹，根据Q列拆分为不同文件夹内的三个工作簿，不同工作簿分别对应K、M、O列品牌数据。（可以不用参照“报表格式”表格，直接拆分即可）

如果各位老师有时间还可以做以下内容
2、若源数据F列为“不含税材料价”，则“报表格式”G列=源数据L/N/P×1.13，保留2为小数；否则，将源数据F列写入报表“备注”。
3、格式参照：“报表格式”第一行为源数据Q列名称&报价单，C列对应源数据K/M/O，H列等于G列乘以F列，D列对应源数据E列。

下图为源数据表


下图为拆分工作簿格式

下图为实现效果


附件如下：
并排多列拆分.rar (68.04 KB, 下载次数: 1)

2024-9-30 09:06 上传

点击文件名下载附件

lele400024

涉及上万行数据，拆分文件夹上百个，一个个手动建太耗时了。拜托各位老师帮助，感谢

limonet

适合付费。

shiruiqiang

商业的，建议付费。虽然可以用字典嵌套做，但需要花费半天时间

lele400024

按自己理解写了一下，但是还是无法实现，请各位老师如果有时间帮忙修改，再次感谢
Sub SplitWorkbooksByMultipleColumns()
    Dim sourceWorkbook As Workbook
    Set sourceWorkbook = Workbooks("数据.xlsx") '请修改为实际的工作簿名称
   
    Dim sourceSheet As Worksheet
    Set sourceSheet = sourceWorkbook.Sheets("源数据")
   
    Dim lastRow As Long
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "Q").End(xlUp).Row
   
    Dim uniqueQValues As New Collection
    Dim i As Long
    For i = 2 To lastRow
        value = sourceSheet.Cells(i, "Q").Value
        On Error Resume Next
        uniqueQValues.Add value, CStr(value)
        On Error GoTo 0
    Next i
   
    Dim desktopPath As String
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
    Dim qValue As Variant
    For Each qValue In uniqueQValues
        Dim uniqueKValues As New Collection
        Dim uniqueMValues As New Collection
        Dim uniqueOValues As New Collection
        
        For i = 2 To lastRow
            If sourceSheet.Cells(i, "Q").Value = qValue Then
                kValue = sourceSheet.Cells(i, "K").Value
                mValue = sourceSheet.Cells(i, "M").Value
                oValue = sourceSheet.Cells(i, "O").Value
                On Error Resume Next
                uniqueKValues.Add kValue, CStr(kValue)
                uniqueMValues.Add mValue, CStr(mValue)
                uniqueOValues.Add oValue, CStr(oValue)
                On Error GoTo 0
            End If
        Next i
        
        Dim kValue As Variant
        Dim mValue As Variant
        Dim oValue As Variant
        For Each kValue In uniqueKValues
            For Each mValue In uniqueMValues
                For Each oValue In uniqueOValues
                    Dim newWorkbook As Workbook
                    Set newWorkbook = Workbooks.Add
                    
                    Dim newSheet As Worksheet
                    Set newSheet = newWorkbook.Sheets(1)
                    newSheet.Name = qValue & "-" & kValue
                    
                    sourceSheet.Range("A1:Q" & lastRow).AutoFilter Field:=17, Criteria1:=qValue '假设 Q 列是第 17 列
                    sourceSheet.Range("A1:Q" & lastRow).AutoFilter Field:=11, Criteria1:=kValue '假设 K 列是第 11 列
                    sourceSheet.Range("A1:Q" & lastRow).AutoFilter Field:=13, Criteria1:=mValue '假设 M 列是第 13 列
                    sourceSheet.Range("A1:Q" & lastRow).AutoFilter Field:=15, Criteria1:=oValue '假设 O 列是第 15 列
                    
                    Select Case newSheet.Name
                        Case qValue & "-" & kValue
                            newSheet.Range("A1").Value = "对应列 L"
                            newSheet.Range("A2").Value = sourceSheet.Cells(2, "L").Value
                            Dim lRow As Long
                            lRow = 2
                            For i = 2 To lastRow
                                If sourceSheet.Cells(i, "Q").Value = qValue And sourceSheet.Cells(i, "K").Value = kValue And sourceSheet.AutoFilterMode Then
                                    lRow = lRow + 1
                                    newSheet.Range("A" & lRow).Value = sourceSheet.Cells(i, "L").Value
                                End If
                            Next i
                        Case qValue & "-" & mValue
                            newSheet.Range("A1").Value = "对应列 N"
                            newSheet.Range("A2").Value = sourceSheet.Cells(2, "N").Value
                            Dim nRow As Long
                            nRow = 2
                            For i = 2 To lastRow
                                If sourceSheet.Cells(i, "Q").Value = qValue And sourceSheet.Cells(i, "M").Value = mValue And sourceSheet.AutoFilterMode Then
                                    nRow = nRow + 1
                                    newSheet.Range("A" & nRow).Value = sourceSheet.Cells(i, "N").Value
                                End If
                            Next i
                        Case qValue & "-" & oValue
                            newSheet.Range("A1").Value = "对应列 P"
                            newSheet.Range("A2").Value = sourceSheet.Cells(2, "P").Value
                            Dim pRow As Long
                            pRow = 2
                            For i = 2 To lastRow
                                If sourceSheet.Cells(i, "Q").Value = qValue And sourceSheet.Cells(i, "O").Value = oValue And sourceSheet.AutoFilterMode Then
                                    pRow = pRow + 1
                                    newSheet.Range("A" & pRow).Value = sourceSheet.Cells(i, "P").Value
                                End If
                            Next i
                    End Select
                    
                    newWorkbook.SaveAs desktopPath & "\" & qValue & "_folder\" & qValue & "-" & kValue & ".xlsx"
                    newWorkbook.Close False
                    
                    MkDir desktopPath & "\" & qValue & "_folder"
                Next oValue
            Next mValue
        Next kValue
    Next qValue
   
    sourceSheet.AutoFilterMode = False
End Sub

ykcbf1100

楼主可以考虑把多个需求拆分成单一需求分别求助，利于解决问题。需求太多，写代码太费时间，大部分人就不愿出手，毕竟不是付费求助。

lele400024

ykcbf1100 发表于 2024-9-30 08:22
楼主可以考虑把多个需求拆分成单一需求分别求助，利于解决问题。需求太多，写代码太费时间，大部分人就不愿 ...

好的，我马上拆分一下需求

lele400024

ykcbf1100 发表于 2024-9-30 08:22
楼主可以考虑把多个需求拆分成单一需求分别求助，利于解决问题。需求太多，写代码太费时间，大部分人就不愿 ...

老师，已经将需求拆分了，看这样可以吗

ykcbf1100

lele400024 发表于 2024-9-30 08:45
老师，已经将需求拆分了，看这样可以吗

你数量用的是哪一列的数据？我看了你拆分后的工作表，数量都是1,和源数据对不上啊。

ykcbf1100

而且，人防就三个记录，你拆分成三个工作簿，而这三个工作簿中的数据都是一样的。你这个拆分逻辑有点问题啊。