[已解决]自动生成若干明细表

wuyanshan · 发表于 2014-10-22 23:46

大家晚上好！能否采用VBA的方式，使工作表中名为“明细分类账”按照B列科目名称，生成7个工作表，样式跟名为“应收工程款（广州汽车配件有限公司）一样，即是科目名称即为工作表名，一个科目名为一个明细表。（不知是否表达清楚了）
工作表名为“目录”是用来链接各个明细表的，是否就是得一个一个的点击链接各个明细表？

谢谢大家！[em23][em23][em23]

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-23 15:42

………………

跳转到最佳答案楼层

dsmch · 发表于 2014-10-23 05:30

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name <> "目录" And Target.Address = "$R$1" Then Sheet1.Activate
End Sub
Sub Macro1()
On Error Resume Next
Dim arr, d
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
arr = Sheets("明细分类账").Range("a1").CurrentRegion
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name <> "目录" And Sheets(i).Name <> "明细分类账" Then Sheets(i).Delete
Next
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 2)) Then
s = s + 1: d(arr(i, 2)) = s & "、"
End If
Next
Range("a4").Resize(d.Count) = Application.Transpose(d.items)
Range("b4").Resize(d.Count) = Application.Transpose(d.keys)
a = d.keys
For i = 0 To d.Count - 1
If Sheets(a(i)) Is Nothing Then
Sheets("明细分类账").[a1].AutoFilter Field:=2, Criteria1:=a(i)
With Sheets.Add(after:=Sheets(Sheets.Count))
.Name = a(i)
Sheets("明细分类账").[a:q].Copy .[a1]
.[r1] = "返回目录"
.Columns.AutoFit
End With
End If
Next
Sheets("明细分类账").ShowAllData
Sheets("目录").Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

dsmch · 发表于 2014-10-23 05:31

………………

Excel学徒123 · 发表于 2014-10-23 08:17

dsmch 发表于 2014-10-23 05:31
………………

这是得有多早啊{:1212:}

Excel学徒123 · 发表于 2014-10-23 08:40

Sub 自动生成明细表()
Dim arr, arr1(1 To 10000, 1 To 17), arrx
Dim i, j, d, sh, intarr, l, k
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Set d = CreateObject("Scripting.dictionary")
For Each sh In Worksheets
If sh.Name <> "明细分类账" And sh.Name <> "目录" Then
sh.Delete
End If
Next
arr = Sheets("明细分类账").Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
arrx = Sheets("明细分类账").Range("A2:Q" & Cells(Rows.Count, 2).End(3).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next i
For j = 1 To d.Count
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Application.Index(d.keys, j)
Sheets("明细分类账").Range("A1:Q1").Copy Sheets(Application.Index(d.keys, j)).Range("A1")
Next j
For j = 1 To d.Count
For k = 1 To UBound(arr1)
If arrx(k, 2) = Application.Index(d.keys, j) Then
l = l + 1
For intarr = 1 To 17
arr1(l, intarr) = arrx(k, intarr)
Next intarr
End If
Next k
Sheets(Application.Index(d.keys, j)).Range("A2").Resize(l, 17) = arr1
Sheets(Application.Index(d.keys, j)).Range("A:A").EntireColumn.Hidden = True
l = 0
Next j
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

我也写一个

wuyanshan · 发表于 2014-10-23 09:34

dsmch 发表于 2014-10-23 05:31
………………

早上好！谢谢您直接帮我做的表！由于上传的只是明细分类账的一小部分，现在我将所有的数据共有两千多行复制到明细分类账中，再点目录的按钮1就没反应了，这是什么状况？

zyouong · 发表于 2014-10-23 09:50

工作表最多只有256个，几千行生成那么多表，怎么看呀，有意义嘛？

wuyanshan · 发表于 2014-10-23 10:00

zyouong 发表于 2014-10-23 09:50
工作表最多只有256个，几千行生成那么多表，怎么看呀，有意义嘛？

您好！两千多行需生成189个明细表，现在都是用软件系统做的，最近在做尽职调查，在资料中要求将公司的应收账款分类做成明细表，我就头都大了。我也觉得没什么用处，但这是资料中要求的，只能硬着头皮在这里看能否找到解决的方了。

wuyanshan · 发表于 2014-10-23 10:08

wuyanshan 发表于 2014-10-23 09:34
早上好！谢谢您直接帮我做的表！由于上传的只是明细分类账的一小部分，现在我将所有的数据共有两千多行复 ...

请看附件，谢谢!

wuyanshan · 发表于 2014-10-23 12:06

wuyanshan 发表于 2014-10-23 10:08
请看附件，谢谢!

您好！可是点了扫钮没有反应哦。

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

[已解决]自动生成若干明细表

评分

点评

点评

点评