求大神，按目录生成工作表

虔诚的小草 · 发表于 2022-12-4 09:13

求助大神，按项目ID生成工作表，并超链接。和在基础数据表中按项目ID获取数据放到对应工作表中。

基础数据表数据有90万多行，数据多，朋友介绍来EH论坛请教帮忙下，非常感谢。

dim麻辣君 · 发表于 2022-12-4 09:18

VBA遍历一遍B列，逐个生成就是

shaowu459 · 发表于 2022-12-4 09:24

帮你转到vba版块，函数公式不适合

Yalishanda30 · 发表于 2022-12-4 09:24

本帖最后由 Yalishanda30 于 2022-12-4 09:46 编辑

90万行生成超链接速度快不了
只做了拆分，超链接没加，第三项看不懂

3190496160 · 发表于 2022-12-4 11:45

1、单单是基础数据表就有90万行数据，如果在拆分为多个工作表在一个文件内，文件就会非常大，估计打开都成问题了，更不用说在做其他的了，
2、加入你拆分为10个工作表，10*90万=9百万行数据，这根本就不是excel能够做的事情了，
3、所以，建议；拆分为多个工作簿文件，
4、在目录中双击B列ID项目，自动打开相应工作簿文件，似乎可行一点吧
5、至于汇总也可以代码遍历所有文件来汇总的，

3190496160 · 发表于 2022-12-4 11:46

Sub 拆分为工作表()
Application.ScreenUpdating = False
Dim ar As Variant, arr As Variant
Dim i As Long, rs As Long
Dim brr()
Dim rng As Range
With Worksheets("目录")
r = .Cells(Rows.Count, 2).End(xlUp).Row
arr = .Range("b1:b" & r)
End With
With Worksheets("基础数据")
rs = .Cells(Rows.Count, 2).End(xlUp).Row
ar = .Range("a4:t" & rs)
Set rng = .Range("a4:t4")
End With
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 3 Then
      sh.Delete
End If
Next sh
Application.DisplayAlerts = True
For i = 2 To UBound(arr)
n = 0
ReDim brr(1 To UBound(ar), 1 To UBound(ar, 2))
If Trim(arr(i, 1)) <> "" Then
      For s = 2 To UBound(ar)
         If Trim(ar(s, 14)) = Trim(arr(i, 1)) Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                  brr(n, j) = ar(s, j)
            Next j
         End If
      Next s
      If n > 0 Then
         Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
         With ActiveSheet
            .Name = arr(i, 1)
            rng.Copy .[a1]
            .[a2].Resize(n, UBound(brr, 2)) = brr
            .[a2].Resize(n, UBound(brr, 2)).Borders.LineStyle = 1
            .Columns("a:t").AutoFit
         End With
      End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2022-12-4 11:47

目前是拆分为工作表，供参考

示例.rar (34.95 KB, 下载次数: 12)

fzxba · 发表于 2022-12-4 17:10

Sub test1() '个人理解，完成1、2 ；第3汇总不参与。
Dim vData, vResult(), Dict As Object, Sht As Worksheet
Dim i As Long, j As Long, posRow As Long, s As String
Dim titleRow As Long, splitCol As Long
titleRow = 4 '标题所在行
splitCol = 14 '拆分依据列
DoApp False
For Each Sht In Worksheets
If Sht.Index > 3 Then Sht.Delete
Next
Set Sht = Worksheets("目录")
Sht.Range("A1").CurrentRegion.Columns(1).Resize(, 2).Offset(1).Clear
Set Dict = CreateObject("Scripting.Dictionary")
With Worksheets("基础数据")
vData = .Range("A1", .Range("A4").CurrentRegion)
End With
ReDim vTemp(1 To UBound(vData), 1 To UBound(vData, 2)) ' As String
For j = 1 To UBound(vData, 2)
For i = 1 To titleRow
vTemp(i, j) = vData(i, j)
Next
Next
For i = titleRow + 1 To UBound(vData)
If Not Dict.Exists(vData(i, splitCol)) Then Dict(vData(i, splitCol)) = Dict.Count + 1
Next
ReDim vResult(1 To Dict.Count, 1 To 2)
For i = 1 To Dict.Count
vResult(i, 1) = titleRow
vResult(i, 2) = vTemp
Next
For i = titleRow + 1 To UBound(vData)
posRow = Dict(vData(i, splitCol))
vResult(posRow, 1) = vResult(posRow, 1) + 1
For j = 1 To UBound(vData, 2)
vResult(posRow, 2)(vResult(posRow, 1), j) = vData(i, j)
Next
Next
For i = 1 To Dict.Count
s = vResult(i, 2)(titleRow + 1, splitCol)
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = s
.Range("A1").Resize(vResult(i, 1), UBound(vData, 2)) = vResult(i, 2)
.Hyperlinks.Add .Cells(1, 1), "", "'" & Sht.Name & "'!A1", "单击返回目录", "返回目录"
End With
With Sht
.Cells(i + 1, 1) = i
.Hyperlinks.Add .Cells(i + 1, 2), "", "'" & s & "'!A1", "单击可跳转到该工作表", s
End With
Next
Sht.Activate
Set Sht = Nothing
Set Dict = Nothing
DoApp
Beep
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function

复制代码

虔诚的小草 · 发表于 2022-12-4 19:48

3190496160 发表于 2022-12-4 11:47
目前是拆分为工作表，供参考

好的，谢谢。才有空来看，没想到这么多人回复。特别感谢大家。

虔诚的小草 · 发表于 2022-12-4 19:50

fzxba 发表于 2022-12-4 17:10

厉害，谢谢。

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

求大神，按目录生成工作表

评分

评分