各位达人帮忙看看代码，谢谢

fushuwei

[color=rgba(0,0,0,0.85)]代码可以正常生成反馈表并按照要求以班级名称命名放入到班级的文件夹中，但是并没有将午餐的姓名放到午餐区域，晚餐的姓名放入晚托的区域，各位大神帮忙看看问题在哪里，谢谢
[color=rgba(0,0,0,0.85)]

[color=rgba(0,0,0,0.85)][color=rgba(0, 0, 0, 0.85)]Sub GenerateDataAndSave()
    Dim arrData As Variant
    Dim lastRow As Long
    Dim sheetData As Worksheet, sheetFeedback As Worksheet
    Dim i As Long
    Set sheetData = ThisWorkbook.Sheets("数据表")
    Set sheetFeedback = ThisWorkbook.Sheets("反馈表")
   
    ' 确定数据表中有数据的行数并读取数据，确保找到真正的最后一行
    lastRow = 1
    For i = sheetData.Rows.Count To 1 Step -1
        If sheetData.Cells(i, "A").Value <> "" Then
            lastRow = i
            Exit For
        End If
    Next i
    If lastRow > 0 Then
        arrData = sheetData.Range("A1:D" & lastRow).Value
    End If
   
    ' 仅当有足够数据行时进行后续操作，提取日期并格式化
    If UBound(arrData) >= 2 Then
        Dim rq As Date
        rq = arrData(2, 3)
        Dim rq1 As String
        ' 正确的日期范围格式化
        rq1 = Format(rq, "yyyy-mm") & "—" & Format(DateAdd("d", -1, DateSerial(Year(rq), Month(rq) + 1, 1)), "yyyy-mm-dd")
        
        ' 创建字典存储数据
        Dim dataDict As Object
        Set dataDict = CreateObject("scripting.dictionary")
        For i = 2 To UBound(arrData)
            dataDict(arrData(i, 1)) = dataDict(arrData(i, 1)) & "|" & arrData(i, 2) & "|" & arrData(i, 4)
        Next i
        
        ' 处理字典数据并填入反馈表
        Dim keysArr As Variant, itemsArr As Variant
        keysArr = dataDict.keys
        itemsArr = dataDict.items
        Dim k As Long
        For k = 0 To UBound(keysArr)
            Dim tempArr As Variant
            tempArr = Split(itemsArr(k), "|")
            Dim n As Integer
            n = 0
            Dim l As Integer
            l = 1
            Dim resultArr As Variant
            ReDim resultArr(1 To 23, 1 To 12)
            Dim j As Long
            For j = 0 To UBound(tempArr) Step 2
                ' 添加数据验证，确保餐次信息正确且不超出tempArr范围
                If j + 2 <= UBound(tempArr) Then
                    If tempArr(j + 1) = "午餐" Or tempArr(j + 1) = "晚餐" Then
                        If tempArr(j + 1) = "午餐" Then
                            n = n + 1
                            If n <= 23 Then
                                resultArr(n, l) = tempArr(j + 2)
                                l = l + 2
                            End If
                        ElseIf tempArr(j + 1) = "晚餐" Then
                            n = n + 1
                            If n <= 23 Then
                                resultArr(n, 7) = tempArr(j + 2)
                            End If
                        End If
                    End If
                End If
            Next j
            
            Dim bt As String
            bt = keysArr(k)
            sheetFeedback.Cells(2, "A") = "班级：" & bt & "         " & "班主任：" & "             " & rq1
            If UBound(resultArr, 1) >= 4 And UBound(resultArr, 2) >= 1 Then
                sheetFeedback.Cells(4, "A").Resize(23, 6) = Application.Index(resultArr, Evaluate("row(1:23)"), Evaluate("column(A:F)"))
            End If
            If UBound(resultArr, 1) >= 4 And UBound(resultArr, 2) >= 7 Then
                sheetFeedback.Cells(4, "G").Resize(23, 6) = Application.Index(resultArr, Evaluate("row(1:23)"), Evaluate("column(G:L)"))
            End If
            Call SaveAsFile(bt) '明确使用Call关键字调用过程，确保名称正确且无作用域问题
        Next k
    End If
End Sub

Sub SaveAsFile(ByVal bt As String) '添加ByVal关键字，明确参数传递方式，也可避免一些潜在问题
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("反馈表")
    ws.Copy
    Dim folderName As String
    folderName = Left(bt, 3)
    If Not FolderExists(ThisWorkbook.Path & "\" & folderName) Then
        MkDir ThisWorkbook.Path & "\" & folderName
    End If
    ActiveWorkbook.SaveAs fileName:=ThisWorkbook.Path & "\" & folderName & "\" & bt & ".xlsx"
    ActiveWorkbook.Close SaveChanges:=False
    Set ws = Nothing
    Exit Sub
ErrorHandler:
    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Error: " & Err.Description
End Sub

Function FolderExists(folderPath As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    FolderExists = fso.FolderExists(folderPath)
End Function
修改代码生成数据部分使数据能够正确填入反馈表中

蓝桥玄霜

数据表的例子：

fushuwei

蓝桥玄霜 发表于 2024-11-3 11:18
数据表的例子：

感谢您百忙中的答复，这个咋用啊，要结合之前的代码？

3190496160

Sub GenerateDataAndSave()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim arr As Variant
Dim lastRow As Long
Dim sheetData As Worksheet, sheetFeedback As Worksheet
Dim i As Long
Dim rq As Date
Set fso = CreateObject("Scripting.FileSystemObject")
Dim rq1 As String
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set sheetData = ThisWorkbook.Sheets("数据表")
Set sheetFeedback = ThisWorkbook.Sheets("反馈表")
' 确定数据表中有数据的行数并读取数据，确保找到真正的最后一行
lastRow = sheetData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "数据表为空": End
arr = sheetData.Range("a1:d" & lastRow)
rq = arr(2, 3)
rq1 = Format(rq, "yyyy-mm") & "—" & Format(DateAdd("d", -1, DateSerial(Year(rq), Month(rq) + 1, 1)), "yyyy-mm-dd")
For i = 2 To UBound(arr)
    If arr(i, 1) <> "" Then
        s = arr(i, 1)
        If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
        d(s)(i) = ""
        nj = Left(arr(i, 1), 3)
        wjj = ThisWorkbook.Path & "\" & nj
        If Not fso.FolderExists(wjj) Then fso.CreateFolder wjj
    End If
Next i
For Each k In d.keys
    n = 0: m = 0
    ReDim brr(1 To UBound(arr), 1 To 2)
    ReDim crr(1 To UBound(arr), 1 To 2)
    For Each kk In d(k).keys
        If arr(kk, 4) = "午餐" Then
            n = n + 1
            brr(n, 1) = n
            brr(n, 2) = arr(kk, 2)
        Else
            m = m + 1
            crr(m, 1) = m
            crr(m, 2) = arr(kk, 2)
        End If
    Next kk
    sheetFeedback.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .Cells(2, 1) = "班级：" & k & "         " & "班主任：" & "             " & rq1
        lh = 1
        For i = 1 To n Step 23
            xh = 3
            For ss = i To i + 22
                If ss <= n Then
                    xh = xh + 1
                    .Cells(xh, lh) = brr(ss, 1)
                    .Cells(xh, lh + 1) = brr(ss, 2)
                End If
            Next ss
            lh = lh + 2
        Next i
        lh = 7
        For i = 1 To m Step 23
            xh = 3
            For ss = i To i + 22
                If ss <= m Then
                    xh = xh + 1
                    .Cells(xh, lh) = crr(ss, 1)
                    .Cells(xh, lh + 1) = crr(ss, 2)
                End If
            Next ss
            lh = lh + 2
        Next i
    End With
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Left(k, 3) & "\" & k & ".xlsx"
    wb.Close SaveChanges:=False
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

数据表.rar (28.63 KB, 下载次数: 6)

2024-11-3 11:50 上传

点击文件名下载附件

ykcbf1100

fushuwei 发表于 2024-11-3 11:41
感谢您百忙中的答复，这个咋用啊，要结合之前的代码？

版主是新写一个代码了。
AI写的代码理解起来费劲，何况代码还有问题。

fushuwei

3190496160 发表于 2024-11-3 11:50

太感谢了，，谢谢