[發問] 將開啟後檔案的指定內容依序複製貼上。

ziv976688

TEST.rar (39.3 KB)

下載次數: 5

2021-8-21 14:41

備註：
7C機資料夾內共有1~98個檔案(本題以5個檔案為例)。

需求：
請將7C機資料夾內的自動開啟檔案，以名稱的第4段數字為基準(EX：7C機_1878期_100_1877-10_1次)~
由大而小~將各已開啟的檔案內之"機率表!"A&B二欄的內容複製後，依序貼上主檔之"Sheet1!"的M1。

請詳見7C_0_1878期_5個(效果檔)。

以上的需求語法
懇請各位大大幫忙和指教 ! 謝謝 !

ziv976688

我的困難點是在無法依第4段數字選擇"由大而小"的順序~
因為無論將"7C機"資料夾內的檔案名稱遞增或遞減排序，
檔案開啟的順序都是"由小而大"，
所以不知道如何起始編寫程式碼 ?

懇請各位大大幫忙和指教 ! 謝謝 !

samwang

回復 2# ziv976688


我的困難點是在無法依第4段數字選擇"由大而小"的順序~
>> 由大至小開啟檔案，修改如下紅字部分，請測試看看，謝謝


Private Sub CommandButton1_Click()
Dim Path As String, a, Ar(1 To 1000, 1 To 2)
    Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
    Tm = Timer
    [L1] = ""
    Application.DisplayAlerts = False
   
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Path = ThisWorkbook.Path
    a = Path & "\7C機"
    Set f = fs.GetFolder(a)
    Set fc = f.Files
    For Each f1 In fc
        n = n + 1
        Ar(n, 1) = a & "\" & f1.Name
        Ar(n, 2) = Split(Split(f1.Name, "_")(3), "-")(0)
    Next
    For i = 1 To UBound(Ar)
    For j = i + 1 To UBound(Ar)
        If Ar(i, 2) < Ar(j, 2) Then
            a = Ar(i, 1)
            Ar(i, 1) = Ar(j, 1)
            Ar(j, 1) = a
        End If
    Next j
    Next i
    For i = 1 To n
        Set WB = Workbooks.Open(Ar(i, 1))
        WB.Close
    Next
      
      
    With Sheets("Sheet1")
        .[A1] = Nrange
        .[A2].Formula = "=CountA(M1:GZ1) / 2 & ""個""": .[A2] = .[A2].Value
        .[A3] = "開獎號碼"
...
...

ziv976688

回復 3# samwang
感謝您的指導

由大而小開啟檔案的需求~OK了~感恩

不好意思，可否勞駕您將各已開啟的檔案內之"機率表!"A&B二欄的內容複製後，
依序由主檔之"Sheet1!"的M1往右貼上的程式語法一併賜教。
謝謝您

samwang

回復 4# ziv976688

可否勞駕您將各已開啟的檔案內之"機率表!"A&B二欄的內容複製後，
依序由主檔之"Sheet1!"的M1往右貼上的程式語法一併賜教。
>> 程式如下紅字，請測試看看，謝謝

For i = 1 To UBound(Ar)    '由大至小排序
    For j = i + 1 To UBound(Ar)
        If Ar(i, 2) < Ar(j, 2) Then
            a = Ar(i, 1)
            Ar(i, 1) = Ar(j, 1)
            Ar(j, 1) = a
        End If
    Next j
    Next i
   
    fileOrg = ActiveWorkbook.Name
    C = 13
    For i = 1 To n
        Set WB = Workbooks.Open(Ar(i, 1))
        With Sheets(1)
            If .FilterMode Then .ShowAllData
            .Range("a1:b" & .[a65536].End(3).Row).Copy Workbooks(fileOrg).Sheets("Sheet1").Cells(1, C)
             C = C + 2
        End With
        WB.Close
    Next
   

    With Sheets("Sheet1")
        .[A1] = Nrange
        .[A2].Formula = "=CountA(M1:GZ1) / 2 & ""個""": .[A2] = .[A2].Value
        .[A3] = "開獎號碼"
        .[A4:A10].Formula = "=IF(A$1="""","""",VLOOKUP(A$1,DATA!$A:$H,ROW()-2,

ziv976688

回復 5# samwang
OK了
謝謝您一再的指導和幫忙~感恩

ziv976688

回復 5# samwang
TEST_0823.rar (225.26 KB)

下載次數: 1

2021-8-23 21:24

Samwang大大：您好!
想以 5#的貴解程式碼再進階：
請將原貴解：以各檔案名稱的第4段數字為基準(EX：7C機_1878期_100_1877-10_1次)~由大而小開啟的程式碼~
進階為：以各資料夾名稱的第5段數字為基準(EX：7C _0_1878期_100_1877-10_1次)~由大而小開啟的程式碼；
然後將各開啟後的資料夾中有關鍵字"機"的檔案(EX：7C機_1878期_100_1877-10_1次)開啟~
再將該開啟後的檔案內之"機率表"的A&B二欄內容複製後，
依序由主檔之"Sheet1!"的M1往右貼上。
請詳見7C_0_1878期_5個(效果檔)
PS：效果檔的內容與5樓的效果檔相同。

以上 懇請賜教 ! 謝謝您 !

samwang

回復 7# ziv976688


以各資料夾名稱的第5段數字為基準(EX：7C _0_1878期_100_1877-10_1次)~由大而小開啟的程式碼；
然後將各開啟後的資料夾中有關鍵字"機"的檔案(EX：7C機_1878期_100_1877-10_1次)開啟~
再將該開啟後的檔案內之"機率表"的A&B二欄內容複製後，
依序由主檔之"Sheet1!"的M1往右貼上。
>> 程式如下，請測試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path$, a, Ar(1 To 1000, 1 To 2), Ar1()
Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
Tm = Timer
[L1] = ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set fs = CreateObject("Scripting.FileSystemObject")
a = ThisWorkbook.Path     '每個資料夾名稱裝入Ar
Set f = fs.GetFolder(a)
Set fc = f.SubFolders
For Each f1 In fc
    n = n + 1
    Ar(n, 1) = f1.Path
    Ar(n, 2) = Split(Split(f1.Name, "_")(4), "-")(0)
Next
For i = 1 To UBound(Ar)   'Ar由大至小排序
For j = i + 1 To UBound(Ar)
    If Ar(i, 2) < Ar(j, 2) Then
        a = Ar(i, 1)
        Ar(i, 1) = Ar(j, 1)
        Ar(j, 1) = a
    End If
Next j
Next i

For i = 1 To n            '開啟Ar，找檔名有"機"裝入Ar1
    Set f = fs.GetFolder(Ar(i, 1))
    Set fc = f.Files
    For Each f1 In fc
        If InStr(f1.Path, "機") Then
            ReDim Preserve Ar1(n1)
            Ar1(n1) = f1.Path
            n1 = n1 + 1
        End If
    Next f1
Next i

fileOrg = ActiveWorkbook.Name
C = 13
If n1 > 0 Then
    For i1 = 0 To n - 1   '開啟Ar1，copy A、B欄資料到Sheet1 M欄開始往右
        Set WB = Workbooks.Open(Ar1(i1))
        With Sheets(1)
            If .FilterMode Then .ShowAllData
            .Range("a1:b" & .[a65536].End(3).Row).Copy Workbooks(fileOrg).Sheets("Sheet1").Cells(1, C)
             C = C + 2
        End With
        WB.Close
    Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing

  
With Sheets("Sheet1")
    .[A1] = Nrange
...
...

ziv976688

回復 8# samwang
samwang大大 : 您好 !
感謝賜教

下載 (33.89 KB)

2021-8-24 08:57

測試後，在列33   ReDim Preserve Ar1(n1)  編輯錯誤(變數未定義)
請問 : 這個變數要怎麼下定義?

Private Sub CommandButton1_Click()
Dim Path As String, a, Ar(1 To 1000, 1 To 2), Ar1( )
這樣對嗎?
謝謝您

samwang

回復 9# ziv976688

對要定義，8#有反紅色有定義，請再測試看看，謝謝
Dim Path As String, a, Ar(1 To 1000, 1 To 2), Ar1( )