vba 分表后表头没有了是什么问题

zhangmy66 · 发表于 2024-9-14 19:37

本帖最后由 zhangmy66 于 2024-9-14 23:30 编辑

sub  test()
Dim arr, i, dic, sht As Worksheet, st As Worksheet
Dim s, k, ar, sr
Set sht = ActiveSheet
Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False

arr = ActiveSheet.UsedRange.Value

For i = 6 To UBound(arr)
      s = arr(i, 9) & "-" & arr(i, 7)
      If Len(s) > 1 Then
         If Not dic.exists(s) Then
            dic(s) = ""
         End If
      End If
Next

For Each k In dic.keys
sht.Copy after:=Sheets(Sheets.Count)
Set st = ActiveSheet
st.Name = k
ar = st.UsedRange.Value
For i = UBound(ar) To 4 Step -1
      s = arr(i, 9) & "-" & arr(i, 7)
      If Len(s) > 1 Then
         If s <> k Then
            Rows(i).Delete
         End If
      End If
Next
[n2].Select
Next
Application.ScreenUpdating = True
Set dic = Nothing: Set sht = Nothing: Set sr = Nothing

End Sub

ykcbf1100 · 发表于 2024-9-14 20:09

楼主的习惯不好，主表为什么第一行要空着呢？第一行如果空的，那使用arr=.Usedrange就会出错，因为这样，Usedrange并没有把第一行计入。

建议楼主以后不要让第一行空着了，不然，处理数据时容易出错。

ykcbf1100 · 发表于 2024-9-14 20:10

参与一下。。。

Sub ykcbf() '//2024.9.14
Dim wb, arr, sh
Application.ScreenUpdating = False
Application.DisplayAlerts = False
p = ThisWorkbook.Path & "\拆分后各班情况"
Set d = CreateObject("Scripting.Dictionary")
Set sh = ThisWorkbook.Sheets("补单")
For Each sht In Sheets
If sht.Name <> sh.Name Then sht.Delete
Next
With sh
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 23)
End With
bt = 5 '//标题行数
col = 9 '//拆分列号
For i = bt + 1 To UBound(arr)
s = arr(i, col)
If s <> Empty Then
If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
d(s)(i) = Application.Index(arr, i)
End If
Next
For Each k In d.keys
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
m = d(k).Count
With sht
.Name = k
sh.Cells.Copy .[a1]
.DrawingObjects.Delete
.[a6].Resize(10000, UBound(arr, 2)) = ""
.UsedRange.Offset(bt + m).Clear
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
End With
Next
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-9-14 20:32

主要原因在于：你的主表第一行为空，在这种情况下，如果使用arr=ActiveSheet.Usedrange时，arr会把第一行弃掉，这样，你再用For i = 6 To UBound(arr)就是错的，应该用For i =5 To UBound(arr)

Qs18 · 发表于 2024-9-14 20:39

Sub qs()
Dim arr, i, dic, rng As Range, sht As Worksheet
Set dic = CreateObject("scripting.dictionary")
With Sheet1
r = .Cells(Rows.Count, "i").End(3).Row
arr = .Range("i1:i" & r).Value
For i = 6 To UBound(arr)
s = arr(i, 1)
If Len(s) > 0 Then
dic(s) = ""
End If
Next
For Each k In dic.keys
Set rng = .Rows("1:5")
For i = 6 To UBound(arr)
If k = arr(i, 1) Then
Set rng = Union(rng, .Rows(i))
End If
Next
Worksheets.Add , Sheets(Sheets.Count)
Set sht = ActiveSheet
rng.Copy sht.Range("a1")
sht.Name = k
Set rng = Nothing
Next
End With
Set dic = Nothing
End Sub

复制代码

Qs18 · 发表于 2024-9-14 20:42

试试。。。。。

Qs18 · 发表于 2024-9-14 20:43

试试。。。。。。。。。。

zhangmy66 · 发表于 2024-9-14 21:45

Qs18 发表于 2024-9-14 20:43
试试。。。。。。。。。。

为啥分出去的表格格式有点变了

zhangmy66 · 发表于 2024-9-14 21:47

ykcbf1100 发表于 2024-9-14 20:09
楼主的习惯不好，主表为什么第一行要空着呢？第一行如果空的，那使用arr=.Usedrange就会出错，因为这样，Us ...

你这个操作这个分出去的表格公式消失了，确实要修改一下模板，但是我把第一行修正了，还是没有标头

zhangmy66 · 发表于 2024-9-14 22:03

ykcbf1100 发表于 2024-9-14 20:09
楼主的习惯不好，主表为什么第一行要空着呢？第一行如果空的，那使用arr=.Usedrange就会出错，因为这样，Us ...

大佬说的确实是，还要少用合并单元格，我重新调整一下表头，一开始用别人给的模板，没有去修改合并单元格，后期添加较多的处理，一直没对表头修正，这回修正一下

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

[已解决] vba 分表后表头没有了是什么问题

评分

评分

评分

[已解决] vba 分表后 表头没有了是什么问题

评分

评分

评分

[已解决] vba 分表后表头没有了是什么问题