数据拆分

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br(), i&, j&, r&, dic As Object
    Dim wks As Worksheet, Shts As Sheets, strFileName$, strPath$
   
    DoApp False
    For Each wks In Sheets
        If wks.Name <> "数据" Then
            r = r + 1
            ReDim Preserve br(1 To r)
            br(r) = wks.Name
        End If
    Next
    Set Shts = Sheets(br)
   
    Set dic = CreateObject("Scripting.Dictionary")
    strPath = ThisWorkbook.Path & "\"
    ar = [A1].CurrentRegion
    For i = 2 To UBound(ar)
        strFileName = strPath & ar(i, 3) & ar(i, 10)
        For j = 1 To UBound(ar, 2): dic(ar(1, j)) = ar(i, j): Next
        Shts.Copy
        With ActiveWorkbook
            For Each wks In .Sheets
                With wks.[A1].CurrentRegion.Resize(2)
                    br = .Value
                    For j = 1 To UBound(br, 2)
                        br(2, j) = dic(br(1, j))
                    Next j
                    .Value = br
                End With
            Next
            .SaveAs strFileName
            .Close
        End With
    Next i
   
    DoApp
    Beep
End Sub

gwjkkkkk

请参考。。。

kongzh

gwjkkkkk 发表于 2023-3-10 20:35
请参考。。。

新生成的文件怎么改？谢谢。式要求是xls，代码l

kongzh

gwjkkkkk 发表于 2023-3-10 20:35
请参考。。。

新生成的文件格式要求是xls，代码怎么改？谢谢。

fzxba

.SaveAs strFileName,56

gwjkkkkk

kongzh 发表于 2023-3-17 16:43
新生成的文件格式要求是xls，代码怎么改？谢谢。

参考15楼。。。