我又来提出新的要求了！

边缘码农 · 发表于 2024-6-27 09:21

danhanqing 发表于 2024-6-26 12:33
工作组两个人同工序，但表中的产量是两个人合计的，对应个人产值也就是1200/2*工价，小组的总产值也只是1 ...

如果40楼截图中的数据没有问题，我整理一下代码发给你。单位有加密软件，不能直接发文件，需要我说步骤，具体你来操作。

danhanqing · 发表于 2024-6-27 09:39

边缘码农发表于 2024-6-27 09:21
如果40楼截图中的数据没有问题，我整理一下代码发给你。单位有加密软件，不能直接发文件，需要我说步骤， ...

看了一下，没有问题！万分感谢！
您不可以直接上传到论坛里么？

danhanqing · 发表于 2024-6-27 09:42

danhanqing 发表于 2024-6-27 09:39
看了一下，没有问题！万分感谢！
您不可以直接上传到论坛里么？

或者您直接把代码直接发到论坛里，注明是放在模块、thisworkbook、或是sheet里，我来组装

边缘码农 · 发表于 2024-6-27 10:27

danhanqing 发表于 2024-6-27 09:42
或者您直接把代码直接发到论坛里，注明是放在模块、thisworkbook、或是sheet里，我来组装

单位有加密软件，编辑过的excel文件是加密的，你打不开。

danhanqing · 发表于 2024-6-27 11:09

边缘码农发表于 2024-6-27 10:27
单位有加密软件，编辑过的excel文件是加密的，你打不开。

哦！那我听您安排吧！再次感谢！

边缘码农 · 发表于 2024-6-27 12:32

日报表体系整理要求
一、基础要求
1、需要进行计算的工作表的表名必须为1-31之间的数字。
2、名称为数字的工作表的结构完全一致（列数保持一致，行数可以不一致，各部分之间有明确的区分方法或标志）。
3、以工作表“1”为例：
（1）、第1行是报表名称行。
（2）、第2-7行汇总数据行区域，其中第2行是标题行，标题包括：款号、订单数、本日数、总完成、未完成、已出货、未出货、备注
注意：
各标题名称中不能有空格。
各行的内容不能包含标题（比如B3单元格的内容中不能有“款号”二字）。
（3）、第9-47行为生产工人数据行区域，其中第9行是标题行，标题包括：款号、姓名、工作内容描述、工时、产量、产值、工资、实发、绩效、备注
注意：
各标题中不能有空格。
各行的内容不能包含标题（比如B10单元格的内容中不能有“款号”二字）。
（4）、第49-53行为非生产工人数据行区域，其标题行通用第9行。
（5）、第56行是合计行。B56单元格的内容必须是“合计：”。
（6）、第57行是备注行。B57单元格的内容必须以“备注：”开始。
（7）、文员输入内容中间不能有空格。
4、工作表各部分可以增加行，但不能删除行。
5、第9-47行生产工人数据行区域，B-G列的内容是其他人输入的，B-D这3列的数据用combobox选择输入。
B列款号的内容来自本表的2-7行汇总数据区域（该区域内容包含在“工时工价表”工作表的A列内容中，如果存在例外，则有错误。A+B列数据不能存在重复）。
C列姓名的内容来组“人事总表”工作表的B列姓名（该列数据不能存在重复）。
D列工作内容描述列的内容来自“工时工价表”工作表的C列，需要根据B列中下拉列表框款项当前选择的具体款号从“工时工价表”工作表的C列提取该款号对应的工序组成，增加到下拉框工作内容的列表项中。输入时要注意：如果该工序是计时的，则需要手工在工作内容的前面输入“计时/”。
二、具体操作
1、以帖子22楼压缩文件包中的Excel文件为准。
2、打开该文件，等载入刷新完毕后，删除名称为2-31的工作表。
下面针对工作表1进行操作：
3、清除H10:M37区域的数据，删除第2行和第9行各标题名称中的空格。
4、按组合键ALT+F11，进入VBE编辑环境。
5、双击左上角的“Sheet1（1）”，删除代码区的所有代码。
然后将下面的代码1复制到该代码区：
6、双击左上角的“ThisWorkbook”，删除代码区的所有代码。
7、双击左上角的“模块1”，删除代码区的所有代码。
然后将下面的代码2复制到该代码区。
8、F47、H47、J47、K47、L47单元格的公式是错误的，应该从第10行开始，修改一下。
L54单元格的公式是不是也有问题？K49:K53单元格区域缺少公式？
将上述提到的、以及自己发现的其他问题，尽数修改，然后执行下列的操作：
9、单击菜单栏【开发工具】，单击【宏】，在弹出的“宏对话框”中，选择“CopySht”，单击【执行】按钮，将工作表1复制到2-31。
10、测试：在不同的工作表中测试各种操作，看有没有出问题的情况。
11、可能存在其他考虑不周的情况，有问题在联系。

边缘码农 · 发表于 2024-6-27 12:33

代码1：

'Option Explicit
Private Sub 刷新_Click()
Call Compute
End Sub
Private Sub 款号_Change()
If 款号 = "" Then Exit Sub
Call 添加款号
Call 生成工作内容列表
款号 = ""
End Sub
Private Sub 姓名_Change()
If 姓名 = "" Then Exit Sub
Call 添加姓名
姓名 = ""
End Sub
Private Sub 工作内容_Change()
If 工作内容 = "" Then Exit Sub
Call 添加工作内容
工作内容 = ""
Range("F" & ActiveSheet.Range("B45").End(xlUp).Row).Select
End Sub
Sub 款号_DropButtonClick()
'---------------------------------
' 填充款号复合框的列表项
' 当在本工作表中单击输入款号的复合框右侧的下拉按钮时
'---------------------------------
' 当本工作表的名称不是数字时，不执行本操作
If Not IsNumeric(ActiveSheet.Name) Then Exit Sub
On Error Resume Next
' 定义字典对象
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim Arrb, kc, I%, aa
' 输出第1区域的所有款项
With ActiveSheet
Arrb = .Range("$B$3:$B$7")
End With
' 生成款号名称连接的字符串
For I = 1 To UBound(Arrb)
aa = aa & Arrb(I, 1) & ","
Next I
' 将款号名称字符串分割到数组
aa = Left(aa, Len(aa) - 1)
kc = Split(aa, ",")
' 将分隔后的数组成员写入字典
For s = 0 To UBound(kc)
d(kc(s)) = ""
Next s
' 将字典中的款号写到复合框中
ActiveSheet.款号.List = d.keys
Set d = Nothing
End Sub
Sub 姓名_DropButtonClick()
'---------------------------------
' 填充姓名复合框的列表项
' 当在本工作表中单击输入姓名的复合框右侧的下拉按钮时
'---------------------------------
' 当本工作表的名称不是数字时，不执行本操作
If Not IsNumeric(ActiveSheet.Name) Then Exit Sub
On Error Resume Next
' 定义字典对象
Dim d1 As Object
Set d1 = CreateObject("scripting.dictionary")
Dim Arrb1, Myrb1%, kc1, i1%, aa1
' 将人事总表的B列姓名列写入数组
With Sheet33
Myrb1 = .[B65536].End(xlUp).Row
Arrb1 = .Range("$B$2:B" & Myrb1)
End With
' 生成姓名连接的字符串
For I = 1 To UBound(Arrb1)
aa1 = aa1 & Arrb1(I, 1) & ","
Next I
' 姓名字符串分隔到数组
aa1 = Left(aa1, Len(aa1) - 1)
kc1 = Split(aa1, ",")
' 分割后的姓名数组写入复合框
For s = 0 To UBound(kc1)
d1(kc1(s)) = ""
Next s
ActiveSheet.姓名.List = d1.keys
Set d1 = Nothing
End Sub

复制代码

边缘码农 · 发表于 2024-6-27 12:36

代码2：因较长，要分几个帖子。

第1部分：

'Option Explicit
Sub 生成工作内容列表()
On Error Resume Next
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim Arrb, myrb%, kc, I%, aa, s%
With Sheet34
myrb = .[A65536].End(xlUp).Row
Arrb = .Range("$A$2:B" & myrb)
End With
For I = 1 To UBound(Arrb)
If Arrb(I, 1) = ActiveSheet.款号.Text Then
aa = aa & Arrb(I, 2) & ","
End If
Next I
aa = Left(aa, Len(aa) - 1)
kc = Split(aa, ",")
For s = 0 To UBound(kc)
d(kc(s)) = ""
Next s
ActiveSheet.工作内容.List = d.keys
Set d = Nothing
End Sub
Sub 添加款号()
Dim myrb
myrb = ActiveSheet.Range("B45").End(xlUp).Row
If ActiveSheet.Range("C" & myrb) = "" Then
ActiveSheet.Range("B" & myrb) = ActiveSheet.款号
Else
ActiveSheet.Range("B" & myrb + 1) = ActiveSheet.款号
End If
End Sub
Sub 添加姓名()
Dim myrb
myrb = ActiveSheet.Range("B45").End(xlUp).Row
ActiveSheet.Range("C" & myrb) = ActiveSheet.姓名
End Sub
Sub 添加工作内容()
Dim myrb
myrb = ActiveSheet.Range("B45").End(xlUp).Row
ActiveSheet.Range("D" & myrb) = ActiveSheet.工作内容
End Sub
Sub CopySht()
'---------------------------
' 复制工作表，将1工作表复制30份，并更改工资表的名称
'---------------------------
' 关闭屏幕更新
Application.ScreenUpdating = False
Dim I As Long
Dim MBSht As Worksheet
Dim CopyS As Boolean
Dim Tsxx As String
CopyS = True '默认复制工作表
With ThisWorkbook.Worksheets
For I = 1 To .Count
'按照工作表的数量进行循环
With Worksheets(I)
If IsNumeric(.Name) Then
' 如果工作表的名称是数字
If Val(.Name) > 1 Then
' 如果工作表名称大于1，则可能已经进行了复制操作。
Tsxx = "工作簿中有多个名称为数字的工作表" & Chr(10) & Chr(10)
Tsxx = Tsxx & "请手工删除除 1 之外的、其他以数字为名称的工作表，在执行复制操作。"
MsgBox Tsxx, vbQuestion, "提醒"
CopyS = False
Exit For
End If
End If
End With
Next
End With
If CopyS Then
Set MBSht = ThisWorkbook.Worksheets("1")
For I = 2 To 31
' 复制指定的工作表
MBSht.Copy Before:=Sheets(I)
' 重命名新复制的工作表
ActiveSheet.Name = I
Next
MsgBox "执行完毕。"
End If
' 恢复屏幕更新
Application.ScreenUpdating = True
End Sub

复制代码

边缘码农 · 发表于 2024-6-27 12:37

代码2，第2部分：

Sub CheckDate()
'---------------------------------------
' 检查数据
'---------------------------------------
Dim ErrXX As String '错误信息文本
Dim ErrXXTotal As String
Dim ShtNameList As String '要检测的工作表名称字符串
Dim ShtExist As Boolean 'Ture=工作表存在
Dim ShtName() As String '各个工作表的名称数组
' 定义行列数变量
Dim MaxRow As Long, MaxCol As Long
Dim RsArr() As Variant ' 定义基础数组：人事总表
Dim GjArr() As Variant ' 定义基础数组：工时工价表
Dim DateArr() As Variant ' 定义基础数组：当前工作表
Dim ListC As String
'---------------------------------------
' 检查项1：检查工作表名称是否被修改。
ShtNameList = "人事总表、工时工价表"
ShtName = Split(ShtNameList, "、")
ShtExist = False
For I = 0 To UBound(ShtName)
For J = 1 To ThisWorkbook.Sheets.Count
If Sheets(J).Name = ShtName(I) Then
ShtExist = True
Exit For
End If
Next
If Not ShtExist Then
If ErrXX = "" Then ErrXX = "下列程序中使用的工作表名称被修改： " & Chr(10)
ErrXX = ErrXX & Chr(10) & " " & ShtName(I)
End If
ShtExist = False
Next
If ErrXX <> "" Then
MsgBox ErrXX, vbOKOnly + vbCritical, "数据校验"
End
End If
'---------------------------------------
' 检查项2：检查工时工价表
' 其1：检查标题是否被修改
' 将询证函信息导入数组
With Sheets("工时工价表")
MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column '第1行最后一列
MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row '第1列最后一行
'将原始数据导入数组
GjArr = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value
End With
TextList = "款号、工序名称、工序组成、工价"
For I = 1 To UBound(GjArr, 2)
If InStr(TextList, GjArr(1, I)) = 0 Then
ErrXX = ErrXX & GjArr(1, I) & "、"
End If
Next
If ErrXX <> "" Then
MsgBox "工时工价表的标题行存在错误：" & ErrXX, vbCritical, "数据校验"
End
End If
ErrXX = ""
' 其2：检查工时工价表中是否存在错误：款号+工序名称存在重复
For I = 2 To UBound(GjArr)
If InStr(ListC, GjArr(I, 1) & GjArr(I, 2) & "结束#") > 0 Then
' 当前款号+工序名称存在重复
ErrXX = ErrXX & GjArr(I, 1) & "，" & GjArr(I, 2) & Chr(10)
Else
' 当前款号+工序名称存不在重复时
ListC = ListC & GjArr(I, 1) & GjArr(I, 2) & "结束#" & ","
End If
Next
If ErrXX <> "" Then
ErrXX = "工时工价表中存在重复的款号+工序名称：" & Chr(10) & ErrXX
ErrXX = ErrXX & Chr(10) & "请修改。"
MsgBox ErrXX, vbCritical, "数据校验"
End
End If
' 其3：检查工时工价表中是否存在错误：工价小于等于0
ErrXX = ""
For I = 2 To UBound(GjArr)
If GjArr(I, 4) <= 0 Then
' 当前款号+工序名称的工价小于等于0，存在错误
ErrXX = ErrXX & GjArr(I, 1) & "，" & GjArr(I, 2) & Chr(10)
End If
Next
If ErrXX <> "" Then
ErrXX = "工时工价表中存在款号+工序名称对应的工价错误情况：" & Chr(10) & ErrXX
ErrXX = ErrXX & Chr(10) & "请修改。"
MsgBox ErrXX, vbCritical, "数据校验"
End
End If
ErrXX = ""
'---------------------------------------
' 检查项3：检查人事总表
' 其1：检查标题是否被修改
' 将询证函信息导入数组
With Sheets("人事总表")
MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column '第1行最后一列
MaxRow = .Cells(.Rows.Count, 2).End(xlUp).Row '第2列最后一行
'将原始数据导入数组
RsArr = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value
End With
TextList = "工号、姓名、时薪"
For I = 1 To UBound(RsArr, 2)
If InStr(TextList, RsArr(1, I)) = 0 Then
ErrXX = ErrXX & RsArr(1, I) & "、"
End If
Next
If ErrXX <> "" Then
MsgBox "人事总表的标题行存在错误：" & ErrXX, vbCritical, "数据校验"
End
End If
' 其2：检查姓名是否存在重复
ErrXX = ""
ListC = ""
For I = 2 To UBound(RsArr)
If InStr(ListC, RsArr(I, 2) & "结束#") > 0 Then
' 当前姓名存在重复
ErrXX = ErrXX & RsArr(I, 1) & Chr(10)
Else
' 当前款号+工序名称存不在重复时
ListC = ListC & RsArr(I, 1) & "结束#" & ","
End If
Next
If ErrXX <> "" Then
MsgBox "人数总表中存在重复的姓名：" & Chr(10) & ErrXX, vbCritical, "数据校验"
End
End If
ErrXX = ""
'---------------------------------------
' 检查项4：检查当前工作表文员录入的数据：款号、姓名、工作内容描述（工序）
With ActiveSheet
'---------------------------------------
' 提取基础数据
' 确认文员输入区的起始行和结束行
MaxRow = .Cells(.Rows.Count, 2).End(xlUp).Row '第2列最后一行
For I = 9 To MaxRow
' 规定生产工人数据行区域至少从第9行开始
If .Cells(I, 2) = "款号" Then
KSRow = I + 1
Exit For
End If
Next
MaxCol = .Cells(I, .Columns.Count).End(xlToLeft).Column '第i行最后一列
' 将数据写入数组
DateArr = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value '将业绩表的内容导入到数组中
' 取得生产工人数据区各列的列次
For J = 2 To MaxCol
Select Case .Cells(I, J)
Case "款号"
KhCol = J
Case "姓名"
XmCol = J
Case "工作内容描述"
NrCol = J
End Select
Next
' 沿着款号列找到结束行
For J = KSRow To MaxRow
' 沿着款号列向下，下一行为空或前两个字是小计，则本行是结束计算行
If .Cells(J + 1, KhCol) = "" Or Left(.Cells(J + 1, KhCol), 2) = "小计" Then
JSRow = J
Exit For
End If
Next
'---------------------------------------
' 文员输入区（目前固定为B-D列）取消底色
With .Range(.Cells(KSRow, 2), .Cells(JSRow, 4)).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'---------------------------------------
' 其1：检查款号列有无错误
For J = KSRow To JSRow
' 检查当前行的款号是否出现在工时工价表中
ErrXX = DateArr(J, KhCol)
For I = 1 To UBound(GjArr)
If DateArr(J, KhCol) = GjArr(I, getNum(GjArr, "款号")) Then
ErrXX = ""
End If
Next
If ErrXX <> "" Then
ErrXXTotal = "错误：第 " & J & " 行；" & " 款号：" & ErrXX
' 错误信息单元格着底色
With .Cells(J, KhCol).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next
'---------------------------------------
' 其2：检查姓名列有无错误
For J = KSRow To JSRow
' 检查当前行的款号是否出现在工时工价表中
ErrXX = DateArr(J, XmCol)
For I = 1 To UBound(RsArr)
If ErrXX = RsArr(I, getNum(RsArr, "姓名")) Then
ErrXX = ""
End If
Next
If ErrXX <> "" Then
ErrXXTotal = ErrXXTotal & Chr(10) & "错误：第 " & J & " 行；" & " 姓名：" & ErrXX
' 错误信息单元格着底色
With .Cells(J, XmCol).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next
'---------------------------------------
' 其3：检查工作内容描述列有无错误
For J = KSRow To JSRow
' 检查当前行的款号是否出现在工时工价表中
ErrXX = DateArr(J, NrCol)
If InStr(ErrXX, "计时/") > 0 Then
' 是计时工序，整理工序名称
ErrXX = Split(ErrXX, "计时/")(1)
End If
For I = 1 To UBound(GjArr)
If ErrXX = GjArr(I, getNum(GjArr, "工序名称")) Then
ErrXX = ""
End If
Next
If ErrXX <> "" Then
ErrXXTotal = ErrXXTotal & Chr(10) & "错误：第 " & J & " 行；" & " 工序：" & ErrXX
' 错误信息单元格着底色
With .Cells(J, NrCol).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next
If ErrXXTotal <> "" Then
MsgBox ErrXXTotal & Chr(10) & Chr(10) & "已更改底色着重显示，请修改。"
End
End If
End With
End Sub

复制代码

边缘码农 · 发表于 2024-6-27 12:38

代码2，第3部分

Function getNum(csArr, csStr As String) As Long
'---------------------------
' 根据接收的参数文本，在接收的参数数组中寻找参数文本是第几个成员，并返回
'
' csArr：二维数组，要检查的数据
' csStr：文本数据，要检查的列次名称，该名称存在于csArr数组的第一行中
'---------------------------
Dim I As Long
For I = 1 To UBound(csArr, 2)
If csArr(1, I) = csStr Then
getNum = I
End If
Next I
End Function
Sub Compute()
'---------------------------------------
' 计算当前工作表
' 计算内容：产值、工资、实发、绩效
'---------------------------------------
' 定义行列数变量
Dim MaxRow As Long, MaxCol As Long
' 定义循环变量
Dim I As Long, J As Long, X As Long
' 定义待计算项在第几列变量：产值、工资、实发、绩效
Dim CzCol As Long, GzCol As Long, SfCol As Long, JxCol As Long
' 定义款号、姓名、工作内容描述、工时、产量所在的列
Dim KhCol As Long, XmCol As Long, NrCol As Long, GsCol As Long, ClCol As Long
Dim KSRow As Long '计算的开始行
Dim JSRow As Long '计算的结束行
Dim MyArr() As Variant ' 定义基础数组
Dim GsArr() As Variant ' 定义工时工价表数组
Dim RsArr() As Variant ' 定义人事总表数组
Dim NowRng As Range '当前处理的单元格
Dim TotalRow As Long
Dim TotalCZ As Double '产值
Dim NowGxnr As String '当前正在处理的行的工作内容描述（工序）
Dim NowKh As String '当前正在处理的行的款号
Dim NowGJ As Double '当前正在处理的行对应的工价
Dim NowCL As Double '当前产量
Dim NowSX As Double '当前时薪
Dim Jsgx As Boolean '计时工序
Dim Xsws As Long '小数位数
Dim GxDict As Object '工序字典
Dim GxKey As String
Dim ErrSL As Long '计算过程中出现错误的数量
'---------------------------------------
Call CheckDate '校验数据
'---------------------------------------
Xsws = 2
Set GxDict = CreateObject("Scripting.Dictionary")
' 取得工时工价表数据
With Sheets("工时工价表")
MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column '第1行最后一列
MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row '第1列最后一行
'将原始数据导入数组
GsArr = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value
End With
'---------------------------------------
' 取得人事总表数据：时薪
With Sheets("人事总表")
MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column '第1行最后一列
MaxRow = .Cells(.Rows.Count, 2).End(xlUp).Row '第2列最后一行
'将原始数据导入数组
RsArr = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value
End With
'---------------------------------------
With ActiveSheet
MaxRow = .Cells(.Rows.Count, 2).End(xlUp).Row '第2列最后一行
For I = 9 To MaxRow
' 规定生产工人数据行区域至少从第9行开始
If .Cells(I, 2) = "款号" Then
KSRow = I + 1
Exit For
End If
Next
MaxCol = .Cells(I, .Columns.Count).End(xlToLeft).Column '第i行最后一列
' 取消底色
With .Range(.Cells(KSRow, 2), .Cells(MaxRow, MaxCol)).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' 将数据写入数组
MyArr = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value '将业绩表的内容导入到数组中
' 取得生产工人数据区各列的列次
For J = 2 To MaxCol
Select Case .Cells(I, J)
Case "产值"
CzCol = J
Case "工资"
GzCol = J
Case "实发"
SfCol = J
Case "绩效"
JxCol = J
Case "款号"
KhCol = J
Case "姓名"
XmCol = J
Case "工作内容描述"
NrCol = J
Case "工时"
GsCol = J
Case "产量"
ClCol = J
End Select
Next
' 沿着款号列找到结束行
For J = KSRow To MaxRow
' 沿着款号列向下，下一行为空或前两个字是小计，则本行是结束计算行
If .Cells(J + 1, KhCol) = "" Or Left(.Cells(J + 1, KhCol), 2) = "小计" Then
JSRow = J
Exit For
End If
Next

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 我又来提出新的要求了！