生成新的工作簿

3190496160 · 发表于 2022-11-1 11:05

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim sh As Worksheet
With Sheets("数据源")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:d" & r)
rs = .Cells(Rows.Count, 7).End(xlUp).Row
br = .Range("g1:i" & rs)
End With
w = MsgBox("拆分为工作表选择是，拆分为工作簿选择否", vbYesNo)
If w = "" Then End
Application.DisplayAlerts = False
If w = vbYes Then
For Each sht In Sheets
      If sht.Index > 2 Then
         sht.Delete
      End If
Next sht
End If
Application.DisplayAlerts = True
Set sh = ThisWorkbook.Worksheets("模板")
For i = 2 To UBound(br)
n = 0
ReDim arr(1 To UBound(ar), 1 To 1)
If Trim(br(i, 1)) <> "" And Trim(br(i, 2)) <> "" Then
      zd = Trim(br(i, 1)) & Trim(br(i, 2))
      For s = 2 To UBound(ar)
         If Trim(ar(s, 1)) <> "" And Trim(ar(s, 2)) <> "" Then
            zf = Trim(ar(s, 1)) & Trim(ar(s, 2))
            If zf = zd Then
                  n = n + 1
                  arr(n, 1) = ar(s, 4)
            End If
         End If
      Next s
      If n > 0 Then
         If w = vbYes Then
            sh.Copy after:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                  .Name = zd
                  .[a1] = "某某学校" & zd & "班学生体温监测表" & Chr(10) & "日期：                   班主任：" & br(i, 3)
                  If n <= 30 Then
                     .[b3].Resize(n, 1) = arr
                  ElseIf n > 30 Then
                     If n / 2 = Int(n / 2) Then
                        sl = n / 2
                     Else
                        sl = Int(n / 2) + 1
                     End If
                     m = 0
                     For s = 1 To n Step sl
                        m = m + 1
                        If m = 1 Then
                              lh = 2
                        Else
                              lh = 8
                        End If
                        hh = 2
                        For ss = s To s + sl - 1
                              If ss <= n Then
                                 hh = hh + 1
                                 .Cells(hh, lh) = arr(ss, 1)
                              End If
                        Next ss
                     Next s
                  End If
            End With
         ElseIf w = vbNo Then
            sh.Copy
            Set wb = ActiveWorkbook
            With wb.Worksheets(1)
                  .Name = zd
                  .[a1] = "某某学校" & zd & "班学生体温监测表" & Chr(10) & "日期：                   班主任：" & br(i, 3)
                  If n <= 30 Then
                     .[b3].Resize(n, 1) = arr
                  ElseIf n > 30 Then
                     If n / 2 = Int(n / 2) Then
                        sl = n / 2
                     Else
                        sl = Int(n / 2) + 1
                     End If
                     m = 0
                     For s = 1 To n Step sl
                        m = m + 1
                        If m = 1 Then
                              lh = 2
                        Else
                              lh = 8
                        End If
                        hh = 2
                        For ss = s To s + sl - 1
                              If ss <= n Then
                                 hh = hh + 1
                                 .Cells(hh, lh) = arr(ss, 1)
                              End If
                        Next ss
                     Next s
                  End If
            End With
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & zd & ".xlsx"
            wb.Close
         End If
      End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "拆分完毕！", 64, "提醒！"
End Sub

3190496160 · 发表于 2022-11-1 11:07

三项需求合并为一个按钮

生成新工作簿.rar (29.12 KB, 下载次数: 23)

熊文来 · 发表于 2022-11-1 17:31

3190496160 发表于 2022-11-1 11:07
三项需求合并为一个按钮

我运行了代码没问题但是格式上有些问题。

1.某某学校年级班学生体温监测表

2.按照30人一组排，不需要将班级人数一分为2排

3.第59号下面那里班主任的姓名没有填充。

3190496160 · 发表于 2022-11-2 08:43

生成新工作簿.rar (35.46 KB, 下载次数: 12)

熊文来 · 发表于 2022-11-2 09:34

本帖最后由熊文来于 2022-11-2 09:49 编辑

3190496160 发表于 2022-11-2 08:43

感谢您的帮助。

1.我刚刚运行了下新的文件，发现生成的工作表标题行中从10班-14班这些班级的不对。

2、还是标题行里。年级和班级的下划线没有添加。

3.还有个小小的要求看能不能再修改下。就是标题行上面一行某某学校这里开始字号大一些，下一行日期这里还是字号小一些可以修改吗？

3190496160 · 发表于 2022-11-6 09:48

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim sh As Worksheet
With Sheets("数据源")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:d" & r)
rs = .Cells(Rows.Count, 7).End(xlUp).Row
br = .Range("g1:i" & rs)
End With
w = MsgBox("拆分为工作表选择是，拆分为工作簿选择否", vbYesNo)
If w = "" Then End
Application.DisplayAlerts = False
If w = vbYes Then
For Each sht In Sheets
      If sht.Index > 2 Then
         sht.Delete
      End If
Next sht
End If
Application.DisplayAlerts = True
Set sh = ThisWorkbook.Worksheets("模板")
For i = 2 To UBound(br)
n = 0
ReDim arr(1 To UBound(ar), 1 To 1)
If Trim(br(i, 1)) <> "" And Trim(br(i, 2)) <> "" Then
      zd = Trim(br(i, 1)) & "|" & Trim(br(i, 2))
      For s = 2 To UBound(ar)
         If Trim(ar(s, 1)) <> "" And Trim(ar(s, 2)) <> "" Then
            zf = Trim(ar(s, 1)) & "|" & Trim(ar(s, 2))
            If zf = zd Then
                  n = n + 1
                  arr(n, 1) = ar(s, 4)
            End If
         End If
      Next s
      If n > 0 Then
         rr = Split(zd, "|")
         If w = vbYes Then
            sh.Copy after:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                  .Name = Replace(zd, "|", "")
                  .[a1] = "某某学校" & rr(0) & "年级" & rr(1) & "班学生体温监测表" & Chr(10) & "日期：                   班主任：" & br(i, 3)
                  If n <= 30 Then
                     .[b4].Resize(n, 1) = arr
                  ElseIf n > 30 Then
                     hh = 3
                     lh = 2
                     For s = 1 To 30
                        hh = hh + 1
                        .Cells(hh, lh) = arr(s, 1)
                     Next s
                     hh = 3
                     lh = 8
                     For s = 31 To n
                        hh = hh + 1
                        .Cells(hh, lh) = arr(s, 1)
                     Next s
                  End If
                  .[h33] = br(i, 3)
                  '.PrintOut
            End With
         ElseIf w = vbNo Then
            sh.Copy
            Set wb = ActiveWorkbook
            With wb.Worksheets(1)
                  .Name = Replace(zd, "|", "")
                  .[a1] = "某某学校" & rr(0) & "年级" & rr(1) & "班学生体温监测表" & Chr(10) & "日期：                   班主任：" & br(i, 3)
                  If n <= 30 Then
                     .[b4].Resize(n, 1) = arr
                  ElseIf n > 30 Then
                     hh = 3
                     lh = 2
                     For s = 1 To 30
                        hh = hh + 1
                        .Cells(hh, lh) = arr(s, 1)
                     Next s
                     hh = 3
                     lh = 8
                     For s = 31 To n
                        hh = hh + 1
                        .Cells(hh, lh) = arr(s, 1)
                     Next s
                  End If
                  .[h33] = br(i, 3)
            End With
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Replace(zd, "|", "") & ".xlsx"
            wb.Close
         End If
      End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "拆分完毕！", 64, "提醒！"
End Sub

3190496160 · 发表于 2022-11-6 09:49

什么下划线纯粹是无聊的游戏，华为不是的东西，没必要

生成新工作簿.rar (35.64 KB, 下载次数: 23)

熊文来 · 发表于 2022-11-6 17:09

3190496160 发表于 2022-11-6 09:49
什么下划线纯粹是无聊的游戏，华为不是的东西，没必要

感谢你的帮助谢谢！

少如 · 发表于 2022-11-7 09:05

本帖最后由少如于 2022-11-7 09:10 编辑

3190496160 发表于 2022-11-6 09:49
什么下划线纯粹是无聊的游戏，华为不是的东西，没必要

3190496160老师：
很好用！点赞！！！

拆分生成新工作簿.zip (85.94 KB, 下载次数: 15)

少如 · 发表于 2022-11-7 09:15

3190496160 发表于 2022-11-6 09:49
什么下划线纯粹是无聊的游戏，华为不是的东西，没必要

如果将新生成的工作薄都放入一个文件夹里就更完美了。

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

[已解决] 生成新的工作簿

评分

评分

评分

评分