Andy2483

¦^´_ 6# singo1232001


    ÁÂÁ«e½úµoªí³o¤£¥²¶}±ÒexcelÀÉ®×´N¥i½Æ»s¸ê®Æªº¤è¦¡
½Ð°Ý³o¨Ç»yªk¦p¦ó¤Jªù¾Ç°_?

singo1232001

Sub test2()
Set CN = CreateObject("adodb.connection"): V = Application.Version
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;"
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;"
Set s = Sheets("¶¶§Ç"): Set s0 = Sheets("¶°¤¤"): s0.Cells.ClearContents
AR = Array("select * from [sheet1$A:I]", "select * from [¤u§@ªí1$A:I]")
For i = 2 To s.Cells(Rows.Count, 2).End(3).Row
If Dir(ThisWorkbook.Path & "\" & s.Cells(i, "C") & ".xlsx") <> "" Then
    CN.Open V & "Data Source=" & ThisWorkbook.Path & "\" & s.Cells(i, "C") & ".xlsx"
    On Error Resume Next
    Set rs = CN.Execute("select * from [" & s.Cells(i, "D") & "$A:I]")
    If CN.Errors.Count <> 0 Then: CN.Errors.Clear: Set rs = CN.Execute(AR(0))
    If CN.Errors.Count <> 0 Then: CN.Errors.Clear: Set rs = CN.Execute(AR(1))
    On Error GoTo 0
    s0.Range(s.Cells(i, "E") & 2).CopyFromRecordset rs
    s0.Columns(s.Cells(i, "E").Value).NumberFormatLocal = "h:mm:ss;@"
    s0.Range(s.Cells(i, "E") & 6).Resize(1, 9) = Split("A,B,C,D,E,F,G,H,I", ",")
    CN.Close
End If
Next
End Sub

Andy2483

¦^´_ 4# oak0723-1


    ÁÂÁ«e½úµoªí¦¹±¡¹Ò»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ßVBA,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

°õ¦æµ²ªG:

¤U¸ü (104.22 KB)

2023-10-16 10:06

Option Explicit
Sub TEST()
Dim Arr, i%, Ph$, xS As Worksheet, xB As Workbook, K%
Application.ScreenUpdating = False
Set xB = ThisWorkbook: Ph = xB.Path & "\"
Arr = Range([¶¶§Ç!E2], [¶¶§Ç!C65536].End(3))
Sheets("¶°¤¤").Cells.Clear
For i = 1 To UBound(Arr)
   On Error Resume Next
   Set xS = Workbooks(Arr(i, 1) & ".xlsx").Sheets(Arr(i, 2))
   If Err.Number <> 0 Then
      Set xS = Workbooks.Open(Ph & Arr(i, 1) & ".xlsx").Sheets(Arr(i, 2))
      K = 1
   End If
   On Error GoTo 0
   If xS Is Nothing Then
      MsgBox Arr(i, 1) & " ¬¡­¶Ã¯, " & Arr(i, 2) & " ¤u§@ªí¤£¦s¦b!µ²§ô°õ¦æ"
      Exit Sub
   End If
   xS.[A:I].Copy xB.Sheets("¶°¤¤").Cells(1, Arr(i, 3))
   If K = 1 Then xS.Parent.Close 0: K = 0
   Set xS = Nothing
Next
Set xB = Nothing: Erase Arr
End Sub

oak0723-1

­Y¿é¤J®æ¦¡§ï¦¨¥i¿é¤JÀɦW©M¤u§@ªí
¨Ì©Ò¿é¤JªºÀɦW©M¤u§@ªí°õ¦æ
­n«ç»ò¼g³o­ÓVBA

oak0723-1

·P®¦.·P®¦
ÁÂÁÂ

samwang

¦^´_ 1# oak0723-1

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ

Sub ¶×¾ãÀÉ®×()
Dim Arr, fs, fc, f1, fn$, xC0, xC1, R%
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False
Tm = Timer
Set fs = CreateObject("Scripting.FileSystemObject")
PH = ThisWorkbook.Path
Set f = fs.GetFolder(PH): Set fc = f.Files
For Each f1 In fc
    If InStr(f1.Name, "¶°¤¤") Then GoTo 99
    If InStr(f1.Name, "~") Then GoTo 99
    With Workbooks.Open(f1.Path)
        fn = Split(f1.Name, ".")(0)
        Arr = Sheets(1).Range("i6").CurrentRegion
        .Close
    End With
    With Sheets(1)
        R = .Range("c65536").End(3).Row + 1
        .Range("c" & R).NumberFormatLocal = "@"
        .Range("c" & R) = fn
        If xC0 = 0 Then
            xC0 = 1: xC1 = UBound(Arr, 2)
        Else
            xC0 = xC1 + 5: xC1 = xC0 + UBound(Arr, 2) - 1
        End If
        .Range("d" & R) = Replace(Cells(1, xC0).Address(0, 0), "1", "")
    End With
    Sheets(2).Cells(6, xC0).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
99: Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True
MsgBox "°õ¦æ§¹¦¨" & Timer - Tm & " ¬í"
End Sub