Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 04-17-2022, 01:44 AM
leeqiang leeqiang is offline How to optimize this code Windows 10 How to optimize this code Office 2019
Advanced Beginner
How to optimize this code
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default 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
Attached Files
File Type: xlsm 工作簿1.xlsm (21.6 KB, 8 views)
Reply With Quote
  #2  
Old 04-17-2022, 04:01 AM
p45cal's Avatar
p45cal p45cal is offline How to optimize this code Windows 10 How to optimize this code Office 2019
Expert
 
Join Date: Apr 2014
Posts: 863
p45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant future
Default

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
or:
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
Reply With Quote
  #3  
Old 04-17-2022, 04:15 AM
leeqiang leeqiang is offline How to optimize this code Windows 10 How to optimize this code Office 2019
Advanced Beginner
How to optimize this code
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

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
Reply With Quote
  #4  
Old 04-18-2022, 05:54 AM
p45cal's Avatar
p45cal p45cal is offline How to optimize this code Windows 10 How to optimize this code Office 2019
Expert
 
Join Date: Apr 2014
Posts: 863
p45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant future
Default

You've got your solution here:
https://www.msofficeforums.com/excel...uirements.html
?
So I don't need to respond?
Reply With Quote
  #5  
Old 04-18-2022, 05:01 PM
leeqiang leeqiang is offline How to optimize this code Windows 10 How to optimize this code Office 2019
Advanced Beginner
How to optimize this code
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Quote:
Originally Posted by p45cal View Post
You've got your solution here:
https://www.msofficeforums.com/excel...uirements.html
?
So I don't need to respond?

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.
Reply With Quote
  #6  
Old 04-20-2022, 07:42 AM
p45cal's Avatar
p45cal p45cal is offline How to optimize this code Windows 10 How to optimize this code Office 2019
Expert
 
Join Date: Apr 2014
Posts: 863
p45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant future
Default

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
Reply With Quote
Reply

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 this code 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 to optimize this code How do I optimize images for Word? fluoresce Drawing and Graphics 1 02-08-2017 06:59 PM
How to optimize this code 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 this code How to optimize an Excel file orosos Excel 2 04-16-2015 01:27 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 11:32 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft