[發問] 指定D3儲存格,執行排序

PJChen

請教大大,

我在工作表sorting.xlsm的D3儲存格輸入一個工作表名稱(因為需排序的工作表有很多,想用動態方法),以指定D3工作表名稱執行排序的巨集程式,但一直無法運作,
上傳附件,可否指點錯誤!
排序.zip (98.38 KB)

下載次數: 16

2012-10-24 11:32

PJChen

回復 2# GBKEE

謝謝G大,

成功了!!

PJChen

回復 4# c_c_lai
當檔案放在同一資料夾時,這樣確實也是一種方便的作業方法, 謝謝你的巧思!

PJChen

回復 2# GBKEE

大大,
我想將指定儲存格的idea依樣畫葫蘆應用到簽名上,
在"貼簽名.xlsm"的"EX" sheet的指定儲存格D3/ G3內的檔名,執行"貼簽名"的動作,但一直出現錯誤

下載 (22.54 KB)

2012-11-2 23:27

巨集程式也附上,可否幫忙看看? 感謝!
貼簽名__指定儲存格內的檔名為對象.zip (129.63 KB)

下載次數: 6

2012-11-2 23:29

PJChen

回復 7# GBKEE

大大,

程式修改以後為以下,但我不是我的原意,我希望將程式中的("Shipping for ACE.xlsx") 替換掉,要如何以"貼簽名.xlsm"的"EX" sheet的指定儲存格D3/ G3內的檔名,取代程式中的檔名With Workbooks("Shipping for ACE.xlsx")  ?

Sub copy_signed()
    Dim Rng(1 To 3) As Range, xi As Integer
    Workbooks("貼簽名.xlsm").Sheets("Signed").Pictures("Picture 1").Copy
    With Workbooks("Shipping for ACE.xlsx")  '***改一改成這樣:前面的With ActiveSheet就沒作用
        Set Rng(1) = .Sheets("PKG").[r:r].Find("B. C. MART COMPANY LTD.", LOOKAT:=xlPart).Offset(2, -2)
        Set Rng(2) = .Sheets("INV").[Q:Q].Find("B. C. MART COMPANY LTD.").Offset(2, -2)
        Set Rng(3) = .Sheets("SCD").[B:B].Find("Signature:").Offset(1, 1)
       End With
        For xi = 1 To 3
            Rng(xi).Parent.Activate
            Rng(xi).Activate
            ActiveSheet.Paste
        Next
    End Sub

PJChen

回復 9# GBKEE
謝謝大大,

這樣執行OK.

PJChen

回復 13# c_c_lai


Hi,

我無法理解
        .Height = 150
        .Width = 150
        .Cut

的意思,可以幫忙解釋嗎?

PJChen

回復 9# GBKEE

大大,

上次程式確認可執行後,我將它應用到其他"TXT"巨集中,出現"陣列索引超出範圍"的對話框,我將將案上傳,可否幫忙看看?
貼簽名__指定儲存格內的檔名為對象.zip (92.11 KB)

下載次數: 4

2012-11-8 18:07

PJChen

回復 9# GBKEE

大大,

我試著修改了一部份程式,程式的用意在以"貼簽名.xlsm"的"EX" sheet的指定儲存格D3內的檔名,執行"TXT"的巨集,現在它可以執行巨集,但出現了個錯誤,可否幫忙指點? ..先謝謝了.
程式執行時,應該將 Shipping for ACE.xlsx的"Booking" sheet的資料copy 到TXT中,現在它雖然做到了,可是連同"貼簽名.xlsm"的"EX" sheet也有copy的動作(整著工作表出現copy後的虛線閃動),我該如何修改,讓它不要執行不正確的copy動作?

以下是修改完後的程式:

1. Sub txt()
   
2. With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)  '改這裡...
   
3. 'Creat a TXT
   
4. With .Sheets("Booking")
   
5. Cells.Select
   
6. Selection.Copy
   
7. Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
   
8. :=False, Transpose:=False
   
9. Dim Rng(1 To 2) As Range, Fs As Object, A As Object, E As Range
   
10. Dim S As Variant, xS As Variant
    
11. Application.ScreenUpdating = False
    
12. End With
    
13. End With
    
14. 
    
15. With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)  '改這裡...
    
16. Set Rng(1) = .Sheets("Booking").[B1:B45] 'Rng(1) 工作表要複製的範圍
    
17. Set Rng(2) = .Sheets("Booking").[A1] 'Rng(2) 存檔名稱的儲存格
    
18. Rng(2) = Rng(2) & "_" & Rng(2).Offset(1) & "_" & Rng(2).Offset(2) 'Rng(2) 存檔檔名須多加[A2]的儲存格名稱
    
19. End With
    
20. 
    
21. Set Fs = CreateObject("Scripting.FileSystemObject") 'FileSystemObject 物件 提供對電腦檔案系統的存取。
    
22. Set A = Fs.CreateTextFile("P:\TXT\" & Rng(2) & ".txt", True) '建立文字檔案
    
23. 
    
24. Debug.Print Rng(1).Cells(27)  'Debug.Print :即時運算視窗 可見到 RAttn:? Mr. Peter Holfelder 中 ? 為 不可見字元 160"
    
25. Rng(1).Replace ChrW(160), ""   '消除不可字元 160
    
26. 
    
27. For Each E In Rng(1) '依序處裡複製範圍的儲存格
    
28. S = Split(E, Chr(10))
    
29. If UBound(S) > -1 Then '***有換行 的文字
    
30. For Each xS In S
    
31. A.WriteLine (xS) '儲存格寫入文字檔
    
32. Next
    
33. Else
    
34. A.WriteLine (E.Text) '儲存格寫入文字檔
    
35. End If
    
36. Next
    
37. A.Close
    
38. 
    
39. Shell "Cmd /c start P:\TXT\" & Rng(2) & ".txt" '自動打開TXT檔
    
40. Application.ScreenUpdating = True
    
41. 
    
42. End Sub

複製代碼

PJChen

回復 9# GBKEE
G大似乎不在家, 不知有人可以幫助我嗎?
我再次修改了程式,發現了另一個問題:("貼簽名.xlsm").Worksheets("EX").Range("D3")的指定檔案若未關閉,則每執行巨集一次,存成TXT的檔名Arctic_USA就會重複一次!

1. Sub txt()
   
2. 
   
3. Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value).Activate '先移到這活頁簿
   
4. 'Creat a TXT
   
5. With Sheets("Booking").Activate
   
6. Cells.Select
   
7. Selection.Copy
   
8. Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
   
9. :=False, Transpose:=False
   
10. Dim Rng(1 To 2) As Range, Fs As Object, A As Object, E As Range
    
11. Dim S As Variant, xS As Variant
    
12. Application.ScreenUpdating = False
    
13. End With
    
14. 
    
15. With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)  '改這裡...
    
16. Sheets("Booking").Select  '這句有無,結果都相同
    
17. Set Rng(1) = .Sheets("Booking").[B1:B45] 'Rng(1) 工作表要複製的範圍
    
18. Set Rng(2) = .Sheets("Booking").[A1] 'Rng(2) 存檔名稱的儲存格
    
19. Rng(2) = Rng(2) & "_" & Rng(2).Offset(1) & "_" & Rng(2).Offset(2) 'Rng(2) 存檔檔名須多加[A2]的儲存格名稱
    
20. End With
    
21. 
    
22. Set Fs = CreateObject("Scripting.FileSystemObject") 'FileSystemObject 物件 提供對電腦檔案系統的存取。
    
23. Set A = Fs.CreateTextFile("P:\TXT\" & Rng(2) & ".txt", True) '建立文字檔案
    
24. 
    
25. Debug.Print Rng(1).Cells(27)  'Debug.Print :即時運算視窗 可見到 RAttn:? Mr. Peter Holfelder 中 ? 為 不可見字元 160"
    
26. Rng(1).Replace ChrW(160), ""   '消除不可字元 160
    
27. 
    
28. For Each E In Rng(1) '依序處裡複製範圍的儲存格
    
29. S = Split(E, Chr(10))
    
30. If UBound(S) > -1 Then '***有換行 的文字
    
31. For Each xS In S
    
32. A.WriteLine (xS) '儲存格寫入文字檔
    
33. Next
    
34. Else
    
35. A.WriteLine (E.Text) '儲存格寫入文字檔
    
36. End If
    
37. Next
    
38. A.Close
    
39. 
    
40. Shell "Cmd /c start P:\TXT\" & Rng(2) & ".txt" '自動打開TXT檔
    
41. Application.ScreenUpdating = True
    
42. 
    
43. End Sub

複製代碼