VBA 编写代码 A表取数到B表，取数过程一部分数据处理

yaozhaoze

hhlty 发表于 2024-1-9 16:47
Sub test()
    Dim ar, br, r, i, k
    k = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

老师您好：
  请您在您编写代码后面增加以下功能：【B表  X列 (项目文本)】 字段不一样分割文件并且命名【B表  X列】字段一致，分割每个文件都标题行，谢谢
以下代码供您参考：

    Dim Arr, i&, wb As Workbook, nm1$
Dim d, k, t, j&, aa
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Sheet3.Activate
Arr = [a1].CurrentRegion
For i = 2 To UBound(Arr)
    d(Arr(i, 8)) = d(Arr(i, 8)) & i & ","
Next
k = d.keys: t = d.items
For i = 0 To UBound(k)
    nm1 = k(i)
    Workbooks.Add
    With ActiveWorkbook
        With .Sheets(1)
            .Cells.NumberFormatLocal = "@"
            .Select
            .[a1].Resize(1, UBound(Arr, 2)) = Application.Index(Arr, 1, 0)
            t(i) = Left(t(i), Len(t(i)) - 1)
            If InStr(t(i), ",") Then
                aa = Split(t(i), ",")
                For j = 0 To UBound(aa)
                    .Cells(j + 2, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, aa(j), 0)
                Next
            Else
                .Cells(j + 2, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, t(i), 0)
            End If
            .Cells.EntireColumn.AutoFit
        End With
        .SaveAs ThisWorkbook.Path & "\" & nm1 & ".xls", 18
        .Close
         j = 0
    End With
Next
Application.ScreenUpdating = True

End Sub

hhlty

Dim ar, br, r, i, k, wb, d, m, n
    k = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    With Sheet1.Sort
        .SortFields.Add Key:=Sheet1.Range("B2:B" & k)
        .SortFields.Add Key:=Sheet1.Range("J2:J" & k)
        .SortFields.Add Key:=Sheet1.Range("K2:K" & k)
        .SetRange Range("A1:T" & k)
        .Header = xlYes
        .Apply
    End With
    ar = Sheet1.[a1].CurrentRegion
    br = Sheet2.Range("A1:X" & k)
    Set d = CreateObject("scripting.dictionary")
    Set r = CreateObject("vbscript.regexp")
    r.Pattern = "\x5b.+\x5d|\x28.+\x29|SQ|AWG|1X"
    r.Global = True
    For i = 2 To k
        br(i, 1) = Split(ar(i, 19), "-")(0)
        br(i, 2) = Format(Split(ar(i, 19), "-")(1), "00000")
        br(i, 6) = ar(i, 15)
        br(i, 17) = Int(ar(i, 11))
        br(i, 18) = ar(i, 3)
        br(i, 19) = Left(ar(i, 3), 4) + 1 & Right(ar(i, 3), 4)
        br(i, 21) = Right(ar(i, 2), 2) & " " & r.Replace(ar(i, 10), "")
        br(i, 24) = Right(ar(i, 2), 2)
        d(br(i, 24)) = 1
    Next i
    Sheet2.Range("X2:X" & k).NumberFormatLocal = "@"
    Sheet2.[a1].Resize(k, 24) = br
   
    For Each m In d.keys
        Set wb = Workbooks.Add
        With wb.Sheets(1)
            .Cells.NumberFormatLocal = "@"
            .[a1].Resize(1, 24) = Application.Index(br, 1, 0)
            n = 1
            For i = 2 To k
                If br(i, 24) = m Then
                    n = n + 1
                    For j = 1 To 24
                        .Cells(n, j) = br(i, j)
                    Next j
                End If
            Next i
        End With
        wb.SaveAs ThisWorkbook.Path & "\" & m & ".xlsx"
        wb.Close
    Next m

yaozhaoze

hhlty 发表于 2024-1-10 09:55
Dim ar, br, r, i, k, wb, d, m, n
    k = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    With Sheet1 ...

老师您好：
  请您有时间帮我解决这个问题，谢谢

VBA 编写代码 从A表取数到B表,取数过程需要一部分数据处理
https://club.excelhome.net/thread-1682318-1-1.html
(出处: ExcelHome技术论坛)

yaozhaoze

hhlty 发表于 2024-1-9 16:47
Sub test()
    Dim ar, br, r, i, k
    k = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

老师请您帮我看看这个问题，麻烦您了，谢谢
修改VBA 代码，完成功能需求
https://club.excelhome.net/thread-1682525-1-1.html
(出处: ExcelHome技术论坛)

yaozhaoze

hhlty 发表于 2024-1-9 16:47
Sub test()
    Dim ar, br, r, i, k
    k = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

老师帮我看看这个

VBA 代码运行把不改变文本显示
https://club.excelhome.net/thread-1682660-1-1.html
(出处: ExcelHome技术论坛)

yaozhaoze

ykcbf1100 发表于 2024-1-9 16:52
第1点不知道在哪里没改，其它改了。

老师帮我看看这个，谢谢
VBA 代码运行把不改变文本显示
https://club.excelhome.net/thread-1682660-1-1.html
(出处: ExcelHome技术论坛)