#1
|
|||
|
|||
How to optimize this code
This code is the code that traverses the file, I want to change this code, so that the result in the second column of the resulting table is added to the hyperlink of the file on the basis of the original, to ensure that clicking on the link can open the file. Thank you!
Code:
Option Explicit Sub GetAllFiles() Dim pth$, arr, i%, r% With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then pth = .SelectedItems(1) Else MsgBox "您没有选择任何文件夹!", vbCritical: Exit Sub End If End With ReDim arr(1 To 6, 1 To 1) arr(1, 1) = "文件名称" arr(2, 1) = "文件位置" arr(3, 1) = "创建日期" arr(4, 1) = "修改日期" arr(5, 1) = "文件类型" arr(6, 1) = "文件大小" Getfd pth, arr arr = Application.WorksheetFunction.Transpose(arr) '文件信息已保存在arr数组中 '实际使用时可不输出到工作表,直接在数组arr中查询需要的文件信息。以下10行可删除 For i = 2 To UBound(arr) arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 1) & """)" Next i Application.ScreenUpdating = False With ActiveSheet .UsedRange.Clear .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr r = .Range("a" & Rows.Count).End(3).Row .Range("a1:f" & r).Borders.LineStyle = xlContinuous .Range("a1:f" & r).Borders.Weight = xlThin End With Application.ScreenUpdating = True [a1].CurrentRegion.AutoFilter Field:=1 '输出结果到工作表,并启用筛选模式 MsgBox "文件已全部获取!点『确定』键结束" End Sub Sub Getfd(ByVal pth As String, arr) Dim fso As Object, f, fd, ff, u Set fso = CreateObject("scripting.filesystemobject") Set ff = fso.GetFolder(pth) For Each f In ff.Files ReDim Preserve arr(1 To 6, 1 To UBound(arr, 2) + 1) u = UBound(arr, 2) arr(1, u) = f.Name arr(2, u) = f arr(3, u) = f.DateCreated arr(4, u) = f.DateLastModified ' arr(5, u) = f.Type Rem 将文件类型修改为文件后缀名 2019-4-15 19:35 arr(5, u) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1) arr(6, u) = Format(f.Size / 1048576, "0.00MB") Next For Each fd In ff.SubFolders: Getfd fd, arr: Next End Sub |
#2
|
||||
|
||||
Without changing your code, in the first column I get the likes of:
=HYPERLINK("C:\Users\Public\Documents\10001.txt"," 10001.txt") while in the second column I get: C:\Users\Public\Documents\10001.txt Clicking on the first column takes me to the correct file, so at the moment I don't understand: "to ensure that clicking on the link can open the file". Otherwise, it's not difficult to get the 2nd parameter to look like: =HYPERLINK("C:\Users\Public\Documents\10000.txt"," C:\Users\Public\Documents\10000.txt") but as far as I'm aware it won't make any difference to whether it opens the correct file or not. You can do that by changing: arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 1) & """)" to: arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 2) & """)" another way to get hyperlinks is to add them without the formula, either by changing to: Code:
With ActiveSheet .UsedRange.Clear .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr r = .Range("a" & Rows.Count).End(3).Row For rw = 2 To UBound(arr) .Hyperlinks.Add Anchor:=.Cells(rw, 1), Address:=arr(rw, 2), TextToDisplay:=arr(rw, 2) Next rw .Range("a1:f" & r).Borders.LineStyle = xlContinuous .Range("a1:f" & r).Borders.Weight = xlThin End With Code:
With ActiveSheet .UsedRange.Clear .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr r = .Range("a" & Rows.Count).End(3).Row For Each cll In .Range("A2:A" & r).Cells .Hyperlinks.Add Anchor:=cll, Address:=cll.Offset(, 1).Value, TextToDisplay:=cll.Offset(, 1).Value Next cll .Range("a1:f" & r).Borders.LineStyle = xlContinuous .Range("a1:f" & r).Borders.Weight = xlThin End With |
#3
|
|||
|
|||
I mean the first column (column A) remains unchanged, and the second column (column B) is superlinked on top of the original, so that you can click to open the file like column A
|
#4
|
||||
|
||||
You've got your solution here:
https://www.msofficeforums.com/excel...uirements.html ? So I don't need to respond? |
#5
|
|||
|
|||
Quote:
The code in these two posts is different. What I want to modify is the code of this post. The code in the link you gave me is fine. |
#6
|
||||
|
||||
Code:
Sub GetAllFiles() Dim pth$, arr, i%, r%, hlink With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then pth = .SelectedItems(1) Else MsgBox "您没有选择任何文件夹!", vbCritical: Exit Sub End If End With ReDim arr(1 To 6, 1 To 1) arr(1, 1) = "文件名称" arr(2, 1) = "文件位置" arr(3, 1) = "创建日期" arr(4, 1) = "修改日期" arr(5, 1) = "文件类型" arr(6, 1) = "文件大小" Getfd pth, arr arr = Application.WorksheetFunction.Transpose(arr) '文件信息已保存在arr数组中 '实际使用时可不输出到工作表,直接在数组arr中查询需要的文件信息。以下10行可删除 For i = 2 To UBound(arr) hlink = arr(i, 2) arr(i, 1) = "=hyperlink(""" & hlink & """,""" & arr(i, 1) & """)" arr(i, 2) = "=hyperlink(""" & hlink & """,""" & hlink & """)" Next i Application.ScreenUpdating = False With ActiveSheet .UsedRange.Clear .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr r = .Range("a" & Rows.Count).End(3).Row .Range("a1:f" & r).Borders.LineStyle = xlContinuous .Range("a1:f" & r).Borders.Weight = xlThin End With Application.ScreenUpdating = True [a1].CurrentRegion.AutoFilter Field:=1 '输出结果到工作表,并启用筛选模式 MsgBox "文件已全部获取!点『确定』键结束" End Sub |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to optimize the size of a slide for export? | Hornswoggled | PowerPoint | 0 | 12-21-2020 09:05 PM |
How to optimize the data summation code for each row and column in a data rectangle area? | leeqiang | Excel Programming | 5 | 10-04-2020 06:53 PM |
How do I optimize images for Word? | fluoresce | Drawing and Graphics | 1 | 02-08-2017 06:59 PM |
VBA Code to search for field codes with certain text before the Field code and to change style | welcometocandyland | Word VBA | 4 | 02-08-2017 06:53 PM |
How to optimize an Excel file | orosos | Excel | 2 | 04-16-2015 01:27 PM |