Sub 生成中山一院预约记录表()
If MsgBox("1、最多只处理500条订单,如超出请联系技术部。2、订单数量大时请耐心等待。", vbOKCancel) <> vbOK Then Exit Sub
ThisWorkbook.Worksheets("sheet2").Unprotect "85666190"
Sheet2.Select
Range("a8:h10000").Select '先清除历史数据
Selection.Delete
i = 3 '订单起始行数为3
j = 2 '打印页的 数据行 起始行数
a = i + 1 '订单第二行
b = i + 2 '订单第三行
c = i + 3 '第四行,如果没有流水号数据将停止复制
k = j + 1 '打印页的第二行数据
l = j + 2 '第三行
m = j + 3 '第四行
n = j + 4 '第五行
o = j + 5
p = j + 7 '复制粘贴的起始行
x = p + 1 '粘贴的第二行
y = j - 1 '复制区域的起始行
e = i - 3 '确定处理的订单数量
f = i - 2
g = i - 1
h = j + 6 '需要调整行高的行
Do While i < 1000 '最大订单数为999
If Sheet1.Cells(i, 1) = "" Then GoTo end1 '没有数据则中止
'If Sheet1.Cells(i, 1) > 0 Then Sheet2.Cells(j, 2) = Sheet1.Cells(i, 1)
If Sheet1.Cells(i, 11) > 0 Then Sheet2.Cells(k, 2) = Sheet1.Cells(i, 11)
If Sheet1.Cells(i, 6) > 0 Then Sheet2.Cells(l, 2) = Left(Sheet1.Cells(i, 6), 7)
If Sheet1.Cells(i, 5) > 0 Then Sheet2.Cells(m, 2) = Left(Sheet1.Cells(i, 5), 7)
If Sheet1.Cells(i, 7) > 0 Then Sheet2.Cells(n, 2) = Sheet1.Cells(i, 8)
If Sheet1.Cells(i, 7) > 0 Then Sheet2.Cells(o, 2) = Sheet1.Cells(i, 7)
If Sheet1.Cells(a, 1) = "" Then GoTo end2
'If Sheet1.Cells(a, 1) > 0 Then Sheet2.Cells(j, 5) = Sheet1.Cells(a, 1)
If Sheet1.Cells(a, 11) > 0 Then Sheet2.Cells(k, 5) = Sheet1.Cells(a, 11)
If Sheet1.Cells(a, 6) > 0 Then Sheet2.Cells(l, 5) = Left(Sheet1.Cells(a, 6), 7)
If Sheet1.Cells(a, 5) > 0 Then Sheet2.Cells(m, 5) = Left(Sheet1.Cells(a, 5), 7)
If Sheet1.Cells(a, 7) > 0 Then Sheet2.Cells(n, 5) = Sheet1.Cells(a, 8)
If Sheet1.Cells(a, 7) > 0 Then Sheet2.Cells(o, 5) = Sheet1.Cells(a, 7)
If Sheet1.Cells(b, 1) = "" Then GoTo end3
'If Sheet1.Cells(b, 1) > 0 Then Sheet2.Cells(j, 8) = Sheet1.Cells(b, 1)
If Sheet1.Cells(b, 11) > 0 Then Sheet2.Cells(k, 8) = Sheet1.Cells(b, 11)
If Sheet1.Cells(b, 6) > 0 Then Sheet2.Cells(l, 8) = Left(Sheet1.Cells(b, 6), 7)
If Sheet1.Cells(b, 5) > 0 Then Sheet2.Cells(m, 8) = Left(Sheet1.Cells(b, 5), 7)
If Sheet1.Cells(b, 7) > 0 Then Sheet2.Cells(n, 8) = Sheet1.Cells(b, 8)
If Sheet1.Cells(b, 7) > 0 Then Sheet2.Cells(o, 8) = Sheet1.Cells(b, 7)
If i = 504 Then MsgBox "需要打印 28 张纸,纸张消耗过大,很不环保,请马上向公司汇报,点击确定继续"
Rows(h).Select
With ActiveWindow.RangeSelection
.RowHeight = 16
End With
If Sheet1.Cells(c, 1) = "" Then GoTo end4
'Range("a1:h6").Select '选择最上面的6行进行复制
Cells(y, 1).Select '选择上面6行进行复制
Selection.Resize(Selection.Rows.Count + 6, Selection.Columns.Count + 8).Select
Selection.Copy
Sheet2.Cells(p, 1).Select
ActiveSheet.Paste
Sheet2.Cells(x, 2).Select '粘贴后先进行原有数据的清除
Selection.Resize(Selection.Rows.Count + 4, Selection.Columns.Count).Select
Selection.ClearContents
Sheet2.Cells(x, 5).Select
Selection.Resize(Selection.Rows.Count + 4, Selection.Columns.Count).Select
Selection.ClearContents
Sheet2.Cells(x, 8).Select
Selection.Resize(Selection.Rows.Count + 4, Selection.Columns.Count).Select
Selection.ClearContents
i = i + 3 '订单每隔三行循环
j = j + 8 '打印页每隔7行循环
a = i + 1
b = i + 2
c = i + 3
k = j + 1
l = j + 2
m = j + 3
n = j + 4
o = j + 5
p = j + 7
x = p + 1
y = j - 1
e = i - 3
f = i - 2
g = i - 1
h = j + 6
Loop
end1:
MsgBox "已处理 " & e & " 条订单,请核对数据是否完整"
GoTo end5
end2:
MsgBox "已处理 " & f & " 条订单,请核对数据是否完整"
GoTo end5
end3:
MsgBox "已处理 " & g & " 条订单,请核对数据是否完整"
GoTo end5
end4:
MsgBox "已处理 " & i & " 条订单,请核对数据是否完整"
GoTo end5
end5:
ThisWorkbook.Worksheets("sheet2").Protect "85666190"
Range("a2").Select
End Sub