excel将一个工作表根据条件拆分成多个工作簿，实现多行表头复制

chxw68

详见附件。

ks331

chxw68 发表于 2017-11-16 22:33
详见附件。

谢谢chxw68老师。固定表头和筛选的宏代码，放入后会出错。
Sub 筛选()
'
' 筛选 宏
'
'
    Range("A2:L2").Select
    Selection.AutoFilter
End Sub




Sub 固定表头 ()
'
' 固定表头
'

'
    Range("F3").Select
    ActiveWindow.SmallScroll Down:=-18
    ActiveWindow.FreezePanes = True
End Sub

chxw68

ks331 发表于 2017-11-17 12:10
谢谢chxw68老师。固定表头和筛选的宏代码，放入后会出错。
Sub 筛选()
'

我写的代码里并没有筛选的代码，我不知道你为什么加入这些代码？

ks331

chxw68 发表于 2017-11-17 12:16
我写的代码里并没有筛选的代码，我不知道你为什么加入这些代码？

chxw68老师，我不会写代码。上次您说关于固定表头、筛选等操作，可以录个宏解决，我以为，录好宏，把宏代码加在您的代码后就能运行，才出现了上面的情况。谢谢您的回复和帮助。另外，我的权限不够，不能发站内信息，希望您在VBA入门学习方面给予指导和帮助。

ks331

chxw68 发表于 2017-11-17 12:16
我写的代码里并没有筛选的代码，我不知道你为什么加入这些代码？

老师，帮看一下。谢谢。
excel文件有大量空白行，文件比较大，需要批量删除同目录下所有文件的空白行。
http://club.excelhome.net/thread-1379940-1-1.html

LMY123

字典拆分成工作薄，并保留格式

补充内容 (2018-12-23 20:58):
'http://club.excelhome.net/thread-1379125-2-1.html
Sub 根据B列_拆分成工作薄_字典法_保留行高列宽_增加合计()
    Set 字典 = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    With Worksheets("sheet1")
        行数 = .Cells(.Rows.Count, 1).End(xlUp).Row
        列数 = .Cells(2, .Columns.Count).End(xlToLeft).Column
        ReDim 表头加标题行数组(1 To 3)
        For 非数据行 = 1 To 3
            表头加标题行数组(非数据行) = .Rows(非数据行).RowHeight
        Next 非数据行
        ReDim 列数数组(1 To 列数)
        For 列 = 1 To 列数
            列数数组(列) = .Columns(列).ColumnWidth
        Next 列
        拆分列数组 = .Range("b1:b" & 行数)
        For 行 = 4 To UBound(拆分列数组)
            If Not 字典.exists(拆分列数组(行, 1)) Then
                Set 字典(拆分列数组(行, 1)) = .Range("a1:k3")
            End If
            Set 字典(拆分列数组(行, 1)) = Union(字典(拆分列数组(行, 1)), .Cells(行, 1).Resize(1, 11))
        Next 行
    End With
    Application.SheetsInNewWorkbook = 1
    For Each 关键字 In 字典.keys
        Set 新生薄 = Workbooks.Add
        With 新生薄
            With .Worksheets(1)
                字典(关键字).Copy .Range("a1")
                行数 = .Cells(.Rows.Count, 1).End(xlUp).Row
                .Range("g3:k3").FormulaR1C1 = "=SUM(R4C:R" & r & "C)"
                For i = 1 To 2
                    .Rows(i).RowHeight = 表头加标题行数组(i)
                Next i
                .Rows("3:" & 行数).RowHeight = 表头加标题行数组(3)
                For 列 = 1 To 列数
                    .Columns(列).ColumnWidth = 列数数组(列)
                Next 列
            End With
            .SaveAs Filename:=ThisWorkbook.Path & "/" & 关键字
            .Close False
        End With
    Next 关键字
    Application.ScreenUpdating = True
    MsgBox "数据拆分完毕！"
End Sub

windky

Sub test()
  Dim r%, i%
  Dim arr, brr, hh(), lk()
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    ReDim hh(1 To 3)
    For i = 1 To 3
      hh(i) = .Rows(i).RowHeight
    Next
    ReDim lk(1 To c)
    For j = 1 To c
      lk(j) = .Columns(j).ColumnWidth
    Next
    arr = .Range("b1:b" & r)
    For i = 4 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
        Set d(arr(i, 1)) = .Range("a1:k3")
      End If
      Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 11))
    Next
  End With
  Application.SheetsInNewWorkbook = 1
  For Each aa In d.keys
    Set wb = Workbooks.Add
    With wb
      With .Worksheets(1)
        d(aa).Copy .Range("a1")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("g3:k3").FormulaR1C1 = "=SUM(R4C:R" & r & "C)"
        For i = 1 To 2
          .Rows(i).RowHeight = hh(i)
        Next
        .Rows("3:" & r).RowHeight = hh(3)
        For j = 1 To c
          .Columns(j).ColumnWidth = lk(j)
        Next
      End With
      .SaveAs Filename:=ThisWorkbook.Path & "" & aa
      .Close False
    End With
  Next
  Application.ScreenUpdating = True
  MsgBox "数据拆分完毕！"
End Sub
这个代码如果列数是36列，然后行数有848行，我还是将要拆分的关键字放在B列就是了。我改哪里呢？
另外这个“Resize(1, 11)"是什么意思？看了上面的解释还是有点不明白。因为拆自己的表格数据还是不成功。我将上面的  Set d(arr(i, 1)) = .Range("a1:k3")这个k3改为aj848后就只生成一个新表，就是等于将原来的整个表搬为新表，然后没有重命名就报错了。
谢谢。

windky

Sub test()
  Dim r%, i%
  Dim arr, brr, hh(), lk()
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    ReDim hh(1 To 3)
    For i = 1 To 3
      hh(i) = .Rows(i).RowHeight
    Next
    ReDim lk(1 To c)
    For j = 1 To c
      lk(j) = .Columns(j).ColumnWidth
    Next
    arr = .Range("b1:b" & r)
    For i = 4 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
        Set d(arr(i, 1)) = .Range("a1:k3")
      End If
      Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 11))
    Next
  End With
  Application.SheetsInNewWorkbook = 1
  For Each aa In d.keys
    Set wb = Workbooks.Add
    With wb
      With .Worksheets(1)
        d(aa).Copy .Range("a1")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("g3:k3").FormulaR1C1 = "=SUM(R4C:R" & r & "C)"
        For i = 1 To 2
          .Rows(i).RowHeight = hh(i)
        Next
        .Rows("3:" & r).RowHeight = hh(3)
        For j = 1 To c
          .Columns(j).ColumnWidth = lk(j)
        Next
      End With
      .SaveAs Filename:=ThisWorkbook.Path & "" & aa
      .Close False
    End With
  Next
  Application.ScreenUpdating = True
  MsgBox "数据拆分完毕！"
End Sub
这个代码如果列数是36列，然后行数有848行，我还是将要拆分的关键字放在B列就是了。我改哪里呢？
另外这个“Resize(1, 11)"是什么意思？看了上面的解释还是有点不明白。因为拆自己的表格数据还是不成功。我将上面的  Set d(arr(i, 1)) = .Range("a1:k3")这个k3改为aj848后就只生成一个新表，就是等于将原来的整个表搬为新表，然后没有重命名就报错了。
谢谢。

windky

Sub test()
  Dim r%, i%
  Dim arr, brr, hh(), lk()
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    ReDim hh(1 To 3)
    For i = 1 To 3
      hh(i) = .Rows(i).RowHeight
    Next
    ReDim lk(1 To c)
    For j = 1 To c
      lk(j) = .Columns(j).ColumnWidth
    Next
    arr = .Range("b1:b" & r)
    For i = 4 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
        Set d(arr(i, 1)) = .Range("a1:k3")
      End If
      Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 11))
    Next
  End With
  Application.SheetsInNewWorkbook = 1
  For Each aa In d.keys
    Set wb = Workbooks.Add
    With wb
      With .Worksheets(1)
        d(aa).Copy .Range("a1")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("g3:k3").FormulaR1C1 = "=SUM(R4C:R" & r & "C)"
        For i = 1 To 2
          .Rows(i).RowHeight = hh(i)
        Next
        .Rows("3:" & r).RowHeight = hh(3)
        For j = 1 To c
          .Columns(j).ColumnWidth = lk(j)
        Next
      End With
      .SaveAs Filename:=ThisWorkbook.Path & "" & aa
      .Close False
    End With
  Next
  Application.ScreenUpdating = True
  MsgBox "数据拆分完毕！"
End Sub
这个代码如果列数是36列，然后行数有848行，我还是将要拆分的关键字放在B列就是了。我改哪里呢？
另外这个“Resize(1, 11)"是什么意思？看了上面的解释还是有点不明白。因为拆自己的表格数据还是不成功。我将上面的  Set d(arr(i, 1)) = .Range("a1:k3")这个k3改为aj848后就只生成一个新表，就是等于将原来的整个表搬为新表，然后没有重命名就报错了。
谢谢。

windky

如果表是有36列，800行，应改哪个参数？谢谢。