12
返回列表 上一主題 發帖

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

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 2012-10-24 11:35 | 只看該作者

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

請教大大,

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
19#
發表於 2012-11-11 15:23 | 只看該作者
回復 18# PJChen
16#  陣列索引超出範圍
  1. With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)  '
  2.    .Activate  '  加這裡...
複製代碼
17# 整著工作表出現copy後的虛線閃動
  1. Application.CutCopyMode = False  '程式結束前加上
複製代碼
18# 每執行巨集一次,存成TXT的檔名Arctic_USA就會重複一次!
  1. Set Rng(2) = .Sheets("Booking").[A1] 'Rng(2) 存檔名稱的儲存格
  2. 'Rng(2) = Rng(2) & "_" & Rng(2).Offset(1) & "_" & Rng(2).Offset(2) 'Rng(2) 存檔檔名須多加[A2]的儲存格名稱
  3. Save_Name = Rng(2) & "_" & Rng(2).Offset(1) & "_" & Rng(2).Offset(2)'改這樣寫
  4. '
  5. '
  6. Set A = Fs.CreateTextFile("P:\TXT\" & Save_Name & ".txt", True) '建立文字檔案
  7. '
  8. '
  9. A.Close
  10. Shell "Cmd /c start P:\TXT\" & Save_Name & ".txt" '自動打開TXT檔
複製代碼

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
18#
發表於 2012-11-10 16:08 | 只看該作者
回復 9# GBKEE
G大似乎不在家, 不知有人可以幫助我嗎?
我再次修改了程式,發現了另一個問題:("貼簽名.xlsm").Worksheets("EX").Range("D3")的指定檔案若未關閉,則每執行巨集一次,存成TXT的檔名Arctic_USA就會重複一次!
  1. Sub txt()

  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

  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

  22. Set Fs = CreateObject("Scripting.FileSystemObject") 'FileSystemObject 物件 提供對電腦檔案系統的存取。
  23. Set A = Fs.CreateTextFile("P:\TXT\" & Rng(2) & ".txt", True) '建立文字檔案

  25. Debug.Print Rng(1).Cells(27)  'Debug.Print :即時運算視窗 可見到 RAttn:? Mr. Peter Holfelder 中 ? 為 不可見字元 160"
  26. Rng(1).Replace ChrW(160), ""   '消除不可字元 160

  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

  40. Shell "Cmd /c start P:\TXT\" & Rng(2) & ".txt" '自動打開TXT檔
  41. Application.ScreenUpdating = True

  43. End Sub
複製代碼

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
17#
發表於 2012-11-10 13:53 | 只看該作者
回復 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

  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

  21. Set Fs = CreateObject("Scripting.FileSystemObject") 'FileSystemObject 物件 提供對電腦檔案系統的存取。
  22. Set A = Fs.CreateTextFile("P:\TXT\" & Rng(2) & ".txt", True) '建立文字檔案

  24. Debug.Print Rng(1).Cells(27)  'Debug.Print :即時運算視窗 可見到 RAttn:? Mr. Peter Holfelder 中 ? 為 不可見字元 160"
  25. Rng(1).Replace ChrW(160), ""   '消除不可字元 160

  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

  39. Shell "Cmd /c start P:\TXT\" & Rng(2) & ".txt" '自動打開TXT檔
  40. Application.ScreenUpdating = True

  42. End Sub
複製代碼

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
16#
發表於 2012-11-8 18:07 | 只看該作者
回復 9# GBKEE

大大,

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

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
15#
發表於 2012-11-5 21:17 | 只看該作者
回復  c_c_lai


Hi,

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

...
PJChen 發表於 2012-11-5 20:49

設定高度、寬度、並將此新加入圖片予以剪下 (Cut)  (指 02.gif) ，
供接下來之下達貼上動作 (PasteSpecial)。

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
14#
發表於 2012-11-5 20:49 | 只看該作者
回復 13# c_c_lai


Hi,

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

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

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
13#
發表於 2012-11-5 17:45 | 只看該作者
回復 11# GBKEE
我把程式碼加入測試 OK 了， 謝謝您的指導！
  1. Sub copySigned2()    ' GBKEE
  2.     Dim Rng(1 To 3) As Range, xi As Integer, Wb As Workbook
  3.    
  4.     Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)
  5.    
  6.     '  Workbooks("貼簽名.xlsm").Sheets("Signed").Pictures("Picture 1").Copy
  7.     With Workbooks("貼簽名.xlsm").Worksheets("EX").Pictures.Insert(ThisWorkbook.Path & "\" & "02.GIF")
  8.         .Height = 150
  9.         .Width = 150
  10.         .Cut
  11.     End With
  12.     '  With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)  '  改這裡...
  13.     With Wb
  14.         Set Rng(1) = .Sheets("PKG").[r:r].Find("B. C. MART COMPANY LTD.", LOOKAT:=xlPart).Offset(2, -2)
  15.         Set Rng(2) = .Sheets("INV").[Q:Q].Find("B. C. MART COMPANY LTD.").Offset(2, -2)
  16.         Set Rng(3) = .Sheets("SCD").[B:B].Find("Signature:").Offset(1, 1)
  17.         For xi = 1 To 3
  18.             Rng(xi).Parent.Activate
  19.             Rng(xi).Activate
  20.             ActiveSheet.PasteSpecial
  21.         Next
  22.     End With
  23. End Sub
複製代碼

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
12#
發表於 2012-11-5 17:42 | 只看該作者
回復 9# GBKEE
謝謝大大,

這樣執行OK.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
11#
發表於 2012-11-5 15:08 | 只看該作者
回復 10# c_c_lai
  1. Option Explicit
  2. Sub Ex()
  3.     With Sheet1.Pictures.Insert("D:\EX1.GIF")
  4.         .Height = 150
  5.         .Width = 150
  6.         .Cut
  7.     End With
  8.     Sheet2.Range("B10").PasteSpecial
  9.    ' Sheet3.Range("C10").PasteSpecial
  10.    ' Sheet4.Range("D10").PasteSpecial
  11. End Sub
複製代碼

TOP

        靜思自在 : 成功是優點的發揮，失敗是缺點的累積。
12
返回列表 上一主題