求execl多条件判断执行代码，能解决有小小心意

zzh201

                               execl office2007表格  求以下操作的代码。

        1.检索当前工作薄，如果有以A5为工作表名的工作表则到下一步（如果A5单元格为空则此代码结束），如果没有就复制名为模版的工作表到工作薄   最后位置并以A5单元格为其命名.
        在以A5为表名的工作表内检索D列，如 果有与表1内C5相同内容的单元格，则在相同内容单元格（如有多个则以第一个为目标）所在行的H列开始（H列不可以修改）向右的第一个空白列填入表1内F5单元格的数值（F5为0或空时则不执行此操作）。如果没有相同内容的单元格则在D列D2向下的第一个空白单元格所在行复制表1内的B5：F5（假设空白单元格为D3，则要将表1内B5：F5复制到当前表内的C3：G3）
       完成以上操作后将表1内H5单元格背景色变为蓝色。
       继续向下重复以上操作直到A列单元格为空。

     2。点击H5的查看时跳转到以A5单元格命名的工作表内与C5单元格内容相同的单元格，以此类推H行的查看跳转。


本人实在才疏学浅，只懂皮毛，求各位大神施以援手，预祝各位大神花开富贵，人生得意，好人一生平安！




补充内容 (2023-5-7 09:41):

感谢大神 3190496160的代码及后续支持，感谢各位大佬的指点，问题已经解决，心意已送出，此贴完结

3190496160

问题不难，就是一些条件判断，但是很繁琐，先留个记号吧

3190496160

Sub 生成工作表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object, dic As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Dim br()
For Each sh In Sheets
    If sh.Index > 3 Then
        dc(sh.Name) = ""
    End If
Next sh
Set sht = Sheets("sheet1")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a4:h" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 5)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            If ar(i, 6) > 0 Then
                n = n + 1
                For j = 2 To 6
                    br(n, j - 1) = ar(i, j)
                Next j
            End If
        End If
    Next i
    If Not dc.exists(k) Then
        Sheets("模版").Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = k
            .[c3].Resize(n, UBound(br, 2)) = br
        End With
    Else
        dic.RemoveAll
        With Sheets(k)
            rs = .Cells(Rows.Count, 4).End(xlUp).Row
            cr = .Range("a1:g" & rs)
            For i = 2 To UBound(cr)
                If Trim(cr(i, 4)) <> "" Then
                    dic(Trim(cr(i, 4))) = i
                End If
            Next i
            m = r
            For i = 1 To n
                If Trim(br(i, 2)) <> "" Then
                    xh = dic(Trim(br(i, 2)))
                    If xh <> "" Then
                        yy = .Cells(xh, Columns.Count).End(xlToLeft).Column + 1
                        .Cells(xh, yy) = br(i, 5)
                    Else
                        m = m + 1
                        For j = 1 To 5
                            .Cells(m, j + 2) = br(i, j)
                        Next j
                    End If
                End If
            Next i
        End With
    End If
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

总表122.rar (39.71 KB, 下载次数: 11)

2023-4-28 16:45 上传

点击文件名下载附件

3190496160

一个初稿，先看看吧，一万有问题，可以加v

zzh201

3190496160 发表于 2023-4-28 16:46
一个初稿，先看看吧，一万有问题，可以加v

感谢大佬回复 表格我下载了，五一左右比较忙，我会尽快测试一下再来反馈。

gwjkkkkk

参与一下。。。

zzh201

3190496160 发表于 2023-4-28 16:45
Sub 生成工作表()
Application.ScreenUpdating = False
Dim ar As Variant

出现一个问题，在数量列为负数时会跳过当前行的处理操作。

zzh201

3190496160 发表于 2023-4-28 11:31
问题不难，就是一些条件判断，但是很繁琐，先留个记号吧

我帐号等级不够，无法加好友，见谅

zzh201

gwjkkkkk 发表于 2023-4-29 13:17
参与一下。。。

感谢参与