从同类型文件中提取数据，然后名字列形成超链接，谢谢老师们~

想不到123

现在数据能提取，但数据多了很慢，A列文件名上超链接不成功，请老师们帮忙指教~

Sub find()
Application.ScreenUpdating = False
Dim Mydir As String
Dim i As Integer
i = 3
Mydir = ThisWorkbook.Path & "\"
ChDrive Left(Mydir, 1)
ChDir Mydir
Match = Dir$("*.xlsx")
Do
If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
Workbooks.Open Match, 0, 1
ThisWorkbook.ActiveSheet.Range("A" & i) = Match
ThisWorkbook.ActiveSheet.Range("B" & i) = ActiveWorkbook.Sheets(1).Range("d3")
ThisWorkbook.ActiveSheet.Range("C" & i) = ActiveWorkbook.Sheets(1).Range("b3")
ThisWorkbook.ActiveSheet.Range("D" & i) = ActiveWorkbook.Sheets(1).Range("d6")
ThisWorkbook.ActiveSheet.Range("E" & i) = ActiveWorkbook.Sheets(1).Range("d7")
ThisWorkbook.ActiveSheet.Range("F" & i) = ActiveWorkbook.Sheets(1).Range("d8")
ThisWorkbook.ActiveSheet.Range("G" & i) = ActiveWorkbook.Sheets(1).Range("d9")
ThisWorkbook.ActiveSheet.Range("H" & i) = ActiveWorkbook.Sheets(1).Range("d10")
ThisWorkbook.ActiveSheet.Range("I" & i) = ActiveWorkbook.Sheets(1).Range("d11")
ThisWorkbook.ActiveSheet.Range("J" & i) = ActiveWorkbook.Sheets(1).Range("d12")
ThisWorkbook.ActiveSheet.Range("K" & i) = ActiveWorkbook.Sheets(1).Range("d13")
ThisWorkbook.ActiveSheet.Range("L" & i) = ActiveWorkbook.Sheets(1).Range("d14")
ThisWorkbook.ActiveSheet.Range("M" & i) = ActiveWorkbook.Sheets(1).Range("d15")
ThisWorkbook.ActiveSheet.Range("N" & i) = ActiveWorkbook.Sheets(1).Range("d16")
ThisWorkbook.ActiveSheet.Range("O" & i) = ActiveWorkbook.Sheets(1).Range("d17")
ThisWorkbook.ActiveSheet.Range("P" & i) = ActiveWorkbook.Sheets(1).Range("d18")
ThisWorkbook.ActiveSheet.Range("Q" & i) = ActiveWorkbook.Sheets(1).Range("d19")
ThisWorkbook.ActiveSheet.Range("R" & i) = ActiveWorkbook.Sheets(1).Range("d20")
ThisWorkbook.ActiveSheet.Range("S" & i) = ActiveWorkbook.Sheets(1).Range("d21")
ActiveWorkbook.Close 0
i = i + 1
End If
Match = Dir$
    Loop
    With wb.Sheets(1)
        For i = 3 To .[a1048576].End(3).Row
            .Hyperlinks.Add Anchor:=.Range("A" & i), Address:= _
                .Range("A" & i).Value & ".xlsx", TextToDisplay:=.Range("A" & i).Value
        Next
End With
Application.ScreenUpdating = True
End Sub

qline302

赋值超链接，你的代码有2个位置建议修改后测试:
1.同目录下, address:=".\" & .range("A"&i) & ".xlsx:
2.表格里的名字不需要带文件名后缀，因为上条链接已加后缀名.

至于提速：多用with..end with语句和set语句，避免重复读对象.

ykcbf1100

直接在单元格上操作不慢才怪，改用数组会快很多。
另外，你可以用with语句去简化代码。

想不到123

ykcbf1100 发表于 2024-1-19 20:47
直接在单元格上操作不慢才怪，改用数组会快很多。
另外，你可以用with语句去简化代码。

谢谢~~~~~~~~~~~~~~~~~~

想不到123

qline302 发表于 2024-1-19 20:30
赋值超链接，你的代码有2个位置建议修改后测试:
1.同目录下, address:=".\" & .range("A"&i) & ".xlsx:
2 ...

谢谢~~~~~~~~~~~