麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 指定D3儲存格,執行排序 [打印本頁]

作者: PJChen 時間: 2012-10-24 11:35 標題: 指定D3儲存格,執行排序

請教大大,

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

作者: GBKEE 時間: 2012-10-24 16:42

回復 1# PJChen
試試看

Sub sorting()
Workbooks(Workbooks("sorting.xlsm").Worksheets("排序").Range("D3").Value).Activate '先移到這活頁簿
'''''' .Activate '要解碼的工作表改成在D3輸入
With ActiveSheet ' With 改在這試試看
Set b = .Range("R4").CurrentRegion
' 其餘2007 屬性方法 2003 中無法使用
'

複製代碼

作者: PJChen 時間: 2012-10-24 16:56

回復 2# GBKEE

謝謝G大,

成功了!!

作者: c_c_lai 時間: 2012-10-24 20:31

回復 3# PJChen
依據GBKEE大大的程式碼也可以修改成：

Sub sorting()
Dim Wb As Workbook
' Workbooks(Workbooks("sorting.xlsm").Worksheets("排序").Range("D3").Value).Activate
' 要解碼的工作表改成在D3輸入，執行時一併要同時開啟 2012 BCMart Chart-Adam 20121023.xls
' 下列修正為執行 sorting.xlsm 時，系統會自動連同將 2012 BCMart Chart-Adam 20121023.xls 一併同時開啟。
Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & Workbooks("sorting.xlsm").Worksheets("排序").Range("D3").Value)
With Wb.ActiveSheet
Set b = .Range("R4").CurrentRegion
A = Array("R", "S", "T", "Q", "D")
.AutoFilter.Sort.SortFields.Clear
For i = 0 To 4
.AutoFilter.Sort.SortFields.Add Key:=b.Columns(A(i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Next
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub

複製代碼

作者: PJChen 時間: 2012-10-25 08:59

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

作者: PJChen 時間: 2012-11-2 23:29

回復 2# GBKEE

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

巨集程式也附上,可否幫忙看看? 感謝!
[attach]13023[/attach]

作者: GBKEE 時間: 2012-11-3 15:45

回復 6# PJChen
請詳看註解

Sub copy_signed()
Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value).Activate '先移到這活頁簿
'***不用先移到這活頁簿:這程式是在Workbooks("貼簽名.xlsm").Worksheets("EX")中呼叫所以是多餘的程式碼.
Dim Rng(1 To 3) As Range, xi As Integer
Workbooks("貼簽名.xlsm").Sheets("Signed").Pictures("Picture 1").Copy
With ActiveSheet '**可註解掉 '*** With 改在這試試看 <= 不是告訴你改一改 ****
.Activate '**可註解掉
With Workbooks("Shipping for ACE.xlsx") '***改一改成這樣:前面的With ActiveSheet就沒作用
'*** .Sheets("PKG") 這點在 With ActiveSheet 是錯誤的一樣都是工作表
Set Rng(1) = .Sheets("PKG").[r:r].Find("B. C. MART COMPANY LTD.", LOOKAT:=xlPart).Offset(2, -2)
'** 原是指定[S:S]會搜索不到的 **
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 With '** 可註解掉
End Sub

複製代碼

作者: PJChen 時間: 2012-11-3 23:40

回復 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

作者: GBKEE 時間: 2012-11-4 16:17

回復 8# PJChen
是這樣嗎?

Sub copy_signed()
Dim Rng(1 To 3) As Range, xi As Integer
Workbooks("貼簽名.xlsm").Sheets("Signed").Pictures("Picture 1").Copy
With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value) '改這裡...
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)
For xi = 1 To 3
Rng(xi).Parent.Activate
Rng(xi).Activate
ActiveSheet.Paste
Next
End With
End Sub

複製代碼

作者: c_c_lai 時間: 2012-11-5 09:43

本帖最後由 c_c_lai 於 2012-11-5 09:44 編輯

回復 8# PJChen
回復 9# GBKEE
上半部如改成如下，個人覺得會方便多。

Sub copySigned() ' GBKEE
Dim Rng(1 To 3) As Range, xi As Integer, Wb As Workbook
Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)
Workbooks("貼簽名.xlsm").Sheets("Signed").Pictures("Picture 1").Copy
' With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value) ' 改這裡...
With Wb
.
.
End With
.

複製代碼

GBKEE 大大，順便請教，如果 "Picture 1"、"Picture 2" 我是在該目錄下存成兩個 .JPG 或是 .BMP 檔，
那又該如何叫進來呢？謝謝您！

作者: GBKEE 時間: 2012-11-5 15:08

回復 10# c_c_lai

Option Explicit
Sub Ex()
With Sheet1.Pictures.Insert("D:\EX1.GIF")
.Height = 150
.Width = 150
.Cut
End With
Sheet2.Range("B10").PasteSpecial
' Sheet3.Range("C10").PasteSpecial
' Sheet4.Range("D10").PasteSpecial
End Sub

複製代碼

作者: PJChen 時間: 2012-11-5 17:42

回復 9# GBKEE
謝謝大大,

這樣執行OK.

作者: c_c_lai 時間: 2012-11-5 17:45

回復 11# GBKEE
我把程式碼加入測試 OK 了，謝謝您的指導！

Sub copySigned2() ' GBKEE
Dim Rng(1 To 3) As Range, xi As Integer, Wb As Workbook
Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value)
' Workbooks("貼簽名.xlsm").Sheets("Signed").Pictures("Picture 1").Copy
With Workbooks("貼簽名.xlsm").Worksheets("EX").Pictures.Insert(ThisWorkbook.Path & "\" & "02.GIF")
.Height = 150
.Width = 150
.Cut
End With
' With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value) ' 改這裡...
With Wb
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)
For xi = 1 To 3
Rng(xi).Parent.Activate
Rng(xi).Activate
ActiveSheet.PasteSpecial
Next
End With
End Sub

複製代碼

作者: PJChen 時間: 2012-11-5 20:49

回復 13# c_c_lai

Hi,

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

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

作者: c_c_lai 時間: 2012-11-5 21:17

回復  c_c_lai

Hi,

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

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

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

作者: PJChen 時間: 2012-11-8 18:07

回復 9# GBKEE

大大,

上次程式確認可執行後,我將它應用到其他"TXT"巨集中,出現"陣列索引超出範圍"的對話框,我將將案上傳,可否幫忙看看?
[attach]13079[/attach]

作者: PJChen 時間: 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動作?

以下是修改完後的程式:

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

複製代碼

作者: PJChen 時間: 2012-11-10 16:08

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

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

複製代碼

作者: GBKEE 時間: 2012-11-11 15:23

回復 18# PJChen
16# 陣列索引超出範圍

With Workbooks(Workbooks("貼簽名.xlsm").Worksheets("EX").Range("D3").Value) '
.Activate ' 加這裡...

複製代碼

17# 整著工作表出現copy後的虛線閃動

Application.CutCopyMode = False '程式結束前加上

複製代碼

18# 每執行巨集一次,存成TXT的檔名Arctic_USA就會重複一次!

Set Rng(2) = .Sheets("Booking").[A1] 'Rng(2) 存檔名稱的儲存格
'Rng(2) = Rng(2) & "_" & Rng(2).Offset(1) & "_" & Rng(2).Offset(2) 'Rng(2) 存檔檔名須多加[A2]的儲存格名稱
Save_Name = Rng(2) & "_" & Rng(2).Offset(1) & "_" & Rng(2).Offset(2)'改這樣寫
'
'
Set A = Fs.CreateTextFile("P:\TXT\" & Save_Name & ".txt", True) '建立文字檔案
'
'
A.Close
Shell "Cmd /c start P:\TXT\" & Save_Name & ".txt" '自動打開TXT檔

複製代碼

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)