Board logo

標題: [發問] 以"指定字"作為copy並貼上值的指定範圍 [打印本頁]
作者: PJChen    時間: 2012-4-28 15:08     標題: 以"指定字"作為copy並貼上值的指定範圍

巨集中的指定範圍作copy並貼上值的動作,能否以"指定字"作為copy並貼上值的指定範圍?這個用意是在於工作表的資料有增加或減少時,用"指定字"作為範圍才不需要不斷的去修改巨集程式,請大家幫幫忙!
例如:D19:O133
以"Shipped per SS: "字樣為開始(D19),以"PACKING:"向右+11個儲存格(即O133)為結束
[attach]10714[/attach]
作者: GBKEE    時間: 2012-4-28 16:07

回復 1# PJChen
  1. Sub Ex()
  2.     Dim Rng(1 To 2) As Range
  3.     With ActiveSheet
  4.         Set Rng(1) = .Range("D:D").Find("Shipped per SS:", LOOKAT:=xlPart)
  5.         Set Rng(2) = .Range("D:D").Find("PACKING:")
  6.         If Rng(1) Is Nothing Or Rng(2) Is Nothing Then
  7.             MsgBox "找不到"
  8.         Else
  9.             .Range(Rng(1), Rng(2)).Resize(, 11).Copy
  10.          End If
  11.     End With
  12. End Sub
複製代碼
作者: PJChen    時間: 2012-4-28 16:43

回復 2# GBKEE
G大,您好

我把您寫的程式套到我的工作表巨集中,但他執行時,無法 作copy並貼上值的動作,我在工作表中打了公式作為實驗,結果另存後就都亂碼了,能否幫我看看問題出在哪?

[attach]10715[/attach]
    Windows("PKG.xlsx").Activate
  
    Sheets("PKG").Select
   
    Dim Rng(1 To 2) As Range
    With ActiveSheet
        Set Rng(1) = .Range("D:D").Find("Shipped per SS:", LOOKAT:=xlPart)
        Set Rng(2) = .Range("D:D").Find("PACKING:")
        If Rng(1) Is Nothing Or Rng(2) Is Nothing Then
            MsgBox "找不到"
        Else
            .Range(Rng(1), Rng(2)).Resize(, 11).Copy
         End If
    End With
   
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("Q122:Q122").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    Rows("143:143").Select
    Selection.ClearContents
    Range("C1").Select
    End With
ActiveWorkbook.SaveAs "P:\Shipping Doc\PJ\" & [Q5] & "_" & [C6] & " PO#" & [V7] & " by " & [C19] & " to " & [C22] & ".xlsx"
        
    Sheets("PKG").Select
    Columns("R:AC").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:C").Select
    Range("C11").Activate
    Selection.Delete Shift:=xlToLeft
   
   
    ActiveWorkbook.Save

   
End Sub
作者: GBKEE    時間: 2012-4-28 17:06

回復 3# PJChen
請先將檔案存有巨集功能的活頁簿為   .xlsm 看看
作者: c_c_lai    時間: 2012-4-28 17:10

回復 2# GBKEE
剛剛拿瞭這個範例做測試，發現 Resize(, 11) 應為 Resize(, 12)，如此範圍才能到達 D19:O133
  1. Sub Ex()
  2.     Dim Rng(1 To 2) As Range
  3.     With ActiveSheet
  4.         Set Rng(1) = .Range("D:D").Find("Shipped per SS:", LOOKAT:=xlPart)
  5.         Set Rng(2) = .Range("D:D").Find("PACKING:")
  6.         If Rng(1) Is Nothing Or Rng(2) Is Nothing Then
  7.             MsgBox "找不到"
  8.         Else
  9.             .Range(Rng(1), Rng(2)).Resize(, 12).Copy Destination:=Sheets(2).Range("A1")
  10.         End If
  11.     End With
  12. End Sub
複製代碼
作者: PJChen    時間: 2012-4-28 18:25

回復 4# GBKEE
回復 5# c_c_lai
[attach]10716[/attach]

二位好,
二種方式我都試了,還是行不通,我的巨集程式都是另存的,我需的是指定範圍作copy並貼上值的動作,結果另存後就都亂碼了,表示巨集中的"copy並貼上值的動作"並沒有生效!
現在我將作好的檔案上傳,能幫我看看出了什麼問題嗎?
作者: c_c_lai    時間: 2012-4-28 19:27

本帖最後由 c_c_lai 於 2012-4-28 19:29 編輯

回復 6# PJChen
試試這個：  最底下那張圖是不小心附上的，妳就當作沒看到！
[attach]10718[/attach]
[attach]10719[/attach]
[attach]10720[/attach]
作者: PJChen    時間: 2012-4-28 19:35

回復 7# c_c_lai
Hi,

我看到你上傳執行巨集後的檔,就跟我執行的結果相同,有公式的地方都是亂碼,我知道巨集可以執行但我需的是指定範圍作copy並貼上值的動作,結果另存後就都亂碼了,表示巨集中的"copy並貼上值的動作"並沒有生效!
作者: c_c_lai    時間: 2012-4-28 19:58

回復 4# GBKEE
回復 8# PJChen
原來指的是這個，G大大這方面您比較在行，換您上場了！
[attach]10721[/attach]
作者: c_c_lai    時間: 2012-4-28 20:27

回復 4# GBKEE
回復 8# PJChen
我找到原因了，如圖示、及代碼 (運算公式)：
  1.     ' Sheets("PKG").Select                           ' *****************
  2.     ' Columns("R:AC").Select                      ' *****************
  3.     ' Selection.Delete Shift:=xlToLeft       ' *****************
  4.     Columns("A:C").Select
  5.     Range("C11").Activate
  6.     Selection.Delete Shift:=xlToLeft
複製代碼
[attach]10722[/attach]
[attach]10723[/attach]
作者: GBKEE    時間: 2012-4-28 20:52

回復 6# PJChen
.Range(Rng(1), Rng(2)).Resize(, 12).Copy Destination:=Sheets(2).Range("A1")
這Sheets(2) 是哪個活頁簿的第2個工作表
PKG.xlsx , Shipping VBA.xlsm 都找不到 這程式可以執行嗎?
作者: PJChen    時間: 2012-4-28 20:57

回復 10# c_c_lai
謝謝你這麼熱心,你將巨集中的以下這3行變成沒有作用,我知道這三行取消後有公式的地方就不會亂碼,但這不是我要的,
    ' Sheets("PKG").Select
    ' Columns("R:AC").Select
    ' Selection.Delete Shift:=xlToLeft
重點應該放在            .Range(Rng(1), Rng(2)).Resize(, 11).Copy   ....這行執行了以後只有copy沒有辦法在選取的範圍中貼上值,只要這個可以"起作用",其它有公式的部份就都不是問題,至於以下的6行是我一定要執行的,不能刪除.
    Sheets("PKG").Select
     Columns("R:AC").Select
     Selection.Delete Shift:=xlToLeft
    Columns("A:C").Select
    Range("C11").Activate
    Selection.Delete Shift:=xlToLeft
作者: PJChen    時間: 2012-4-28 21:18

回復 11# GBKEE
[attach]10724[/attach]
Hi,

我將這個程式分階段執行了很多次,知道這個旨令沒有寫完,它只到copy並沒有在原指定範圍中貼上值,而且以下這樣做並不合乎我想要以"指定文字"作為設定的範圍,     .Range(Rng(1), Rng(2)).Resize(, 12).Copy Destination:=Sheets(2).Range("A1")
請幫我看看附件,我已將巨集程式 copy進去,只是不知道.Range(Rng(1), Rng(2)).Resize(, 12).Copy之後如何做?
我不是要在其它的sheet    .Range("A1")中貼上值,而是要讓它在原設定的範圍貼上值,請幫幫忙.
作者: Hsieh    時間: 2012-4-28 21:29

本帖最後由 Hsieh 於 2012-4-28 21:37 編輯

回復 13# PJChen

請依照目前PKG現有資料，你想要的最後結果用手動操作完成上傳
因為以你錯誤的程式碼是無法了解你要的目的為何
如果單純將該範圍轉成值
  1. Sub Try()

  3. With Workbooks("PKG.xlsx")
  4.     With .Sheets("PKG")
  5.         Set a = .Range("D:D").Find("Shipped per SS:", LOOKAT:=xlPart)
  6.         Set b = .Range("D:D").Find("PACKING:")
  7.         If a Is Nothing Or b Is Nothing Then
  8.             MsgBox "找不到"
  9.         Else
  10.             .Range(a, b.Offset(, 11)) = .Range(a, b.Offset(, 11)).Value
  11.         End If
  12.     End With
  13. End With
  14. End Sub
複製代碼
至於其他動作請描述清楚
作者: PJChen    時間: 2012-4-28 22:07

回復 14# Hsieh

謝版大,
執行後沒有問題,但請指教一個範圍上的問題:
b的範圍這樣寫可以向右延伸12格....... b.Offset(, 12)
那如果a的範圍我想向上走11格,我改為以下,為什麼它不能執行?
.Range(a.Offset(, -11), b.Offset(, 12)) = .Range(a.Offset(, -11), b.Offset(, 12)).Value
作者: Hsieh    時間: 2012-4-28 22:14

回復 15# PJChen

有2個問題
1.向上11格式Offset(-11,0)
2.如果a的位置在1到11列之間，那麼，向上11列就會超出工作表範圍，所以出錯。
作者: PJChen    時間: 2012-4-28 22:24

回復 16# Hsieh
不好意思版大,
由"Shipped per SS:"向上11格(儲存格D4)在我的工作表上是沒有超出範圍,但我故意在D4放置了公式,修改為以下的樣子,
貼上值之後D4公式還在,所以  .Range(a.Offset(-11, 0)並沒有向上11格,我該怎麼辦?
如果你需要看檔案,我上傳了  [attach]10726[/attach]
            .Range(a.Offset(-11, 0), b.Offset(, 12)) = .Range(a.Offset(-11, 0), b.Offset(, 12)).Value
作者: Hsieh    時間: 2012-4-28 23:00

回復 17# PJChen


    D19是變數a的位置，向上11列也只到D8
你忽略了14到18列被隱藏，沒算這4列所以範圍沒包含D4
作者: PJChen    時間: 2012-4-28 23:06

回復 18# Hsieh

謝謝版大,
原來是自已大意
作者: c_c_lai    時間: 2012-4-29 06:40

本帖最後由 c_c_lai 於 2012-4-29 06:42 編輯

回復 19# PJChen
這是不是妳要的？
[attach]10729[/attach]
[attach]10730[/attach]
  1. Sub Try()
  2.     Dim Rng(1 To 2) As Range
  3.    
  4.     Windows("PKG.xlsx").Activate

  6.      '  加入 Hsieh 先進的引用方法
  7.     With Workbooks("PKG.xlsx")
  8.         With .Sheets("PKG")
  9.             Set Rng(1) = .Range("D:D").Find("Shipped per SS:", LOOKAT:=xlPart)
  10.             Set Rng(2) = .Range("D:D").Find("PACKING:")
  11.             
  12.             If Rng(1) Is Nothing Or Rng(2) Is Nothing Then
  13.                 MsgBox "找不到"
  14.             Else     '  依照 Hsieh 先進的指示，稍加修飾
  15.                .Range(Rng(1), Rng(2).Offset(, 11)) = .Range(Rng(1), Rng(2)).Resize(, 12).Value
  16.             End If
  17.         End With
  18.     End With
  19.    
  20.    
  21.     Selection.Copy
  22.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  23.         :=False, Transpose:=False
  24.     Range("Q122:Q122").Select
  25.     Selection.Copy
  26.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  27.         :=False, Transpose:=False
  28.     ActiveSheet.Paste
  29.     Rows("143:143").Select
  30.     Selection.ClearContents
  31.     Range("C1").Select
  32.    
  33.     ActiveWorkbook.SaveAs "D:\Shipping Doc\PJ\" & [Q5] & "_" & [C6] & " PO#" & [V7] & " by " & [C19] & " to " & [C22] & ".xlsx"
  34.         
  35.     Sheets("PKG").Select                         ' 恢復原狀
  36.     Columns("R:AC").Select                    ' 恢復原狀
  37.     Selection.Delete Shift:=xlToLeft     ' 恢復原狀
  38.     Columns("A:C").Select
  39.     Range("C11").Activate
  40.     Selection.Delete Shift:=xlToLeft
  41.    
  42.     ActiveWorkbook.Save
  43. End Sub
複製代碼
[attach]10731[/attach]
作者: PJChen    時間: 2012-4-29 12:47

回復 20# c_c_lai
結果看來是相同的.
作者: c_c_lai    時間: 2012-4-29 14:20

回復 21# PJChen
Please check the CI12-460_ACE PO#120309 by FEDEX to .xlsx produced  this morning
in D:\Shipping Doc\PJ subdirectory.
作者: JOYARK    時間: 2012-5-1 05:44

謝謝提供學習非常實用



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