求大神编写代码，自动生成目录表

张其祥 · 发表于 2024-4-28 23:58

求大神编写代码。

张其祥 · 发表于 2024-4-29 06:25

请大神编写代码

liulang0808 · 发表于 2024-4-29 07:48

楼主具体需求是什么，结合附件描述下
是拆分还是汇总？

baofa2 · 发表于 2024-4-29 08:02

Sub test1() '是否完成不知怎么填……
Dim results(), ar, br(1), cel As Range, vrt
Dim i As Long, j As Long, cnt As Long
Dim Conn As Object, re As Object, dict As Object, vKey
Dim strConn As String, SQL As String, s As String, p As String, f As String
Set Conn = CreateObject("ADODB.Connection")
Set dict = CreateObject("Scripting.Dictionary")
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.Pattern = "(\D+)(\d+)(\D+)(\d+)"
ar = Split("B3 D3 D2 F3")
For Each vrt In ar
For Each cel In Range(vrt)
s = cel.Address(, , xlR1C1)
For j = 4 To 2 Step -2
br(-CInt(j = 2)) = re.Replace(s, "$" & j) - 1
Next
dict.Add Join(br, "|"), dict.Count + 1
Next
Next
ReDim results(1 To 2345, 1 To dict.Count + 1)
Set re = Nothing
ActiveSheet.UsedRange.Offset(2).ClearContents
Application.ScreenUpdating = False
s = "Excel 12.0;HDR=NO;IMEX=1;Database="
If Application.Version < 12 Then
s = Replace(s, "12.0", "8.0")
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
End If
'Conn.Open strConn & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\"
SQL = "SELECT * FROM [" & s & p & "[.f]].[$A1:F3]"
f = Dir(p & "*.xls*")
Do
If f <> ThisWorkbook.Name Then
cnt = cnt + 1
If cnt = 1 Then Conn.Open strConn & p & f
ar = Conn.Execute(Replace(SQL, "[.f]", f)).GetRows
For Each vKey In dict.Keys
vrt = Split(vKey, "|")
results(cnt, dict(vKey)) = ar(vrt(0), vrt(1))
Next
results(cnt, UBound(results, 2)) = "是否怎么填？"
End If
f = Dir
Loop While f <> ""
Range("A3").Resize(cnt, UBound(results, 2)) = results
Conn.Close
Set Conn = Nothing
Set dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

Justin-2016 · 发表于 2024-4-29 08:17

张其祥发表于 2024-4-29 06:27

从附件上来看，需要把需求逻辑写出来，这样别人才能理解意思，比如“是否完成”以什么条件来判断显示。

ykcbf1100 · 发表于 2024-4-29 08:17

是否完成，这个没地方取值呢。

心的启点 · 发表于 2024-4-29 08:28

光一个表，到底你要根据什么样的条件达到什么样的结果，要描述清楚啊，别人又不知道你的想法，怎么给你写代码？

ykcbf1100 · 发表于 2024-4-29 08:32

是否完成项没地方取值，其它完成。

ykcbf1100 · 发表于 2024-4-29 08:33

参与一下。。。

Sub ykcbf() '//2024.4.29
Set fso = CreateObject("scripting.filesystemobject")
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("目录")
p = ThisWorkbook.Path & ""
b = [{"b3","d3","d2","f3"}]
ReDim brr(1 To 1000, 1 To 5)
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = fso.GetBaseName(f)
m = m + 1
Set wb = Workbooks.Open(f, 0)
With wb.Sheets(1)
For x = 1 To UBound(b)
brr(m, x) = .Range(b(x))
Next
wb.Close False
End With
End If
End If
Next f
With sh
.UsedRange.Offset(2).Clear
With .[a3].Resize(m, 5)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

张其祥 · 发表于 2024-4-30 21:46

ykcbf1100
EH侠圣：
非常感谢您在百忙中帮我解惑。由于我还是菜鸟，第一发贴时好像附件没有上传，造成连发了几次。说声抱歉。以后一定注意，坚决改正。
是否完成一项，是日后根据工作实际，由自己标注就行了。您已经经完美解决了我的难题。谢谢。

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

[求助] 求大神编写代码，自动生成目录表

请大神编写代码

评分