我验证过了没问题，我希望能不能在“编号”前面再加一列“箱数”，箱数按合计数来确定，第一个合计数箱数就为1。（还有请高手把合计数放在数量2那列，还有标题要改下，谢谢，不甚感激！）
效果如图：
箱号 编号 名称 JobName 数量1 数量2 挂号信编号 挂号信截止编号 卡函 插页 会员号
1 80001 钻石卡 ccb1 7 7 45471305 45471311 高尔夫 1
1 80101 白痴卡 ccb2 10 9 45471312 45471320
1 80202 变态卡 ccb3 500 500 45471321 45471820
1 合计 516
2 80202 变态卡 ccb3 500 500 45471821 45472320
2 合计 500
3 80202 变态卡 ccb3 500 500 45472321 45472820
3 合计 500
4 80202 变态卡 ccb3 600 500 45472821 45473320
4 合计 500
。。。。
------解决方案--------------------------------------------------------
我的代码逻辑层次那么清晰，你把 Sub ProcData() 改一下不就搞定了吗？
- VBScript code
Sub ProcData(strBookFile$, retVal) Dim objNewBook As Workbook, objNewSheet As Worksheet Dim objOldBook As Workbook, objOldSheet As Worksheet Dim strTemp$, strFields$(3) Dim lNumA&, lNumB&, lCode&, lBoxNum& Dim lCountA&, lCountB&, lDataSave& Dim i&, j&, k& On Error GoTo Err_Handle retVal = 1 ' 打开工作薄 Set objOldBook = Workbooks.Open(strBookFile, True, True) retVal = 2 ' 格式验证 j = 1 For i = 1 To objOldBook.Sheets.Count Do Set objOldSheet = objOldBook.Sheets(i) If (objOldSheet.Range("A1").Text <> "编号") Then Exit Do If (objOldSheet.Range("B1").Text <> "名称") Then Exit Do If (objOldSheet.Range("C1").Text <> "JobName") Then Exit Do If (objOldSheet.Range("D1").Text <> "数量1") Then Exit Do If (objOldSheet.Range("E1").Text <> "数量2") Then Exit Do If (objOldSheet.Range("F1").Text <> "挂号信编号") Then Exit Do If (objOldSheet.Range("G1").Text <> "其它") Then Exit Do j = 2: Exit For Loop Next If (j = 1) Then Exit Sub ' 新建工作薄 If (WorksheetFunction.Count(objOldSheet.Range("E:E")) > 0) Then Set objNewBook = Workbooks.Add Set objNewSheet = objNewBook.Sheets(1) objNewSheet.Range("A1").Formula = "箱号" objNewSheet.Range("B1").Formula = "编号" objNewSheet.Range("C1").Formula = "名称" objNewSheet.Range("D1").Formula = "JobName" objNewSheet.Range("E1").Formula = "数量1" objNewSheet.Range("F1").Formula = "数量2" objNewSheet.Range("G1").Formula = "挂号信编号" objNewSheet.Range("H1").Formula = "挂号信截止编号" objNewSheet.Range("I1").Formula = "卡函" objNewSheet.Range("J1").Formula = "插页" objNewSheet.Range("K1").Formula = "会员号" Else Exit Sub End If ' 处理数据 i = 1: j = 1: lBoxNum = 1 lCountA = 0: lDataSave = 0 Do i = i + 1 lNumA = Val(objOldSheet.Cells(i, 4)) lNumB = Val(objOldSheet.Cells(i, 5)) If (lNumB = 0) Then lCountB = lCountA lCountA = lCountA + lDataSave If (lCountA >= 550) Then Rows(j).Insert objNewSheet.Range("A" & j).Formula = lBoxNum objNewSheet.Range("B" & j).Formula = "合计" objNewSheet.Range("F" & j).Formula = lCountB objNewSheet.Range("F" & j).Font.Bold = True objNewSheet.Range("F" & j).Font.ColorIndex = 3 '红色文字 lCountA = lDataSave j = j + 1 lBoxNum = lBoxNum + 1 objNewSheet.Range("A" & j).Formula = lBoxNum End If j = j + 1 objNewSheet.Range("A" & j).Formula = lBoxNum objNewSheet.Range("B" & j).Formula = "合计" objNewSheet.Range("F" & j).Formula = lCountA objNewSheet.Range("F" & j).Font.Bold = True objNewSheet.Range("F" & j).Font.ColorIndex = 3 Exit Do End If lCode = Val(objOldSheet.Cells(i, 6)) For k = 1 To 3 strFields(k) = objOldSheet.Cells(i, k) Next strFields(0) = objOldSheet.Cells(i, 7) Do lCountB = lCountA lCountA = lCountA + lDataSave If (lCountA >= 550) Then Rows(j).Insert objNewSheet.Range("A" & j).Formula = lBoxNum objNewSheet.Range("B" & j).Formula = "合计" objNewSheet.Range("F" & j).Formula = lCountB objNewSheet.Range("F" & j).Font.Bold = True objNewSheet.Range("F" & j).Font.ColorIndex = 3 lCountA = lDataSave j = j + 1 lBoxNum = lBoxNum + 1 objNewSheet.Range("A" & j).Formula = lBoxNum End If j = j + 1 objNewSheet.Cells(j, 1).Formula = lBoxNum objNewSheet.Cells(j, 2).Formula = strFields(1) objNewSheet.Cells(j, 3).Formula = strFields(2) objNewSheet.Cells(j, 4).Formula = strFields(3) objNewSheet.Cells(j, 9).Formula = strFields(0) If (lNumB > 500) Then objNewSheet.Cells(j, 5).Formula = 500 objNewSheet.Cells(j, 6).Formula = 500 objNewSheet.Cells(j, 7).Formula = lCode lCode = lCode + 500 objNewSheet.Cells(j, 8).Formula = lCode - 1 lNumA = lNumA - 500 lNumB = lNumB - 500 lDataSave = 500 Else objNewSheet.Cells(j, 5).Formula = lNumA objNewSheet.Cells(j, 6).Formula = lNumB objNewSheet.Cells(j, 7).Formula = lCode lCode = lCode + lNumB - 1 objNewSheet.Cells(j, 8).Formula = lCode lDataSave = lNumB Exit Do End If Loop Loop objNewSheet.Range("A:A").HorizontalAlignment = xlCenter ' A列 水平居中 objOldBook.Close 0 retVal = 0 Exit SubErr_Handle: If (retVal > 1) Then objOldBook.Close 0End Sub