Board logo

標題: 請問：關於修改VBA語法 [打印本頁]
作者: jsc0518    時間: 2018-2-2 14:54     標題: 請問：關於修改VBA語法

Dear 先進,

VBA語法如下，語法內有把"空白"都給刪除
我想把"若遇到A欄列空白時，不要刪除"，請問是要修正哪一段語法呢？

感謝各位！

Sub Step1()
'刪除 key word : 公司 / 單別: / 日期* / 產品大類: / 核准 / 合計* / 統計*
Dim reg As Object, a, rng As Range, z&
a = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row).Value
z = UBound(a)
Set rng = Rows(z + 1)
Set reg = CreateObject("vbscript.regexp")
With reg
    .Pattern = "空白|公司|單別:|日期|產品大類:|核准|合計|總計"
    For i = 1 To z
        If Len(a(i, 1)) = 0 Or .test(a(i, 1)) Then
            Set rng = Union(rng, Rows(i))
        End If
    Next
End With
rng.Delete
Set rng = Nothing
End Sub
作者: ikboy    時間: 2018-2-2 17:17

try this:
  1. Sub Step1()
  2. '刪除 key word : 公司 / 單別: / 日期* / 產品大類: / 核准 / 合計* / 統計*
  3. Dim reg As Object, a, rng As Range, z&
  4. a = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row).Value
  5. z = UBound(a)
  6. Set rng = Rows(z + 1)
  7. Set reg = CreateObject("vbscript.regexp")
  8. With reg
  9.     .Pattern = "空白|公司|單別:|日期|產品大類:|核准|合計|總計"
  10.     For i = 1 To z
  11.         If .test(a(i, 1)) Then
  12.             Set rng = Union(rng, Rows(i))
  13.         End If
  14.     Next
  15. End With
  16. rng.Delete
  17. Set rng = Nothing
  18. End Sub
複製代碼
作者: jsc0518    時間: 2018-2-3 09:48

回復 2# ikboy
Dear 謝謝您的回覆,
下列語法是將A欄列若有出現關鍵字時，就刪除該列
但我想把其中一個關鍵字"空白"-->若遇A欄列為空白時，就不要刪除
我改了
原本：    .Pattern = "空白|公司|單別:|日期|產品大類:|核准|合計|總計"
更改：    .Pattern = "公司|單別:|日期|產品大類:|核准|合計|總計"
但A欄列空白該列也會一併刪除
是否哪一段VBA語法需做修改呢？








Sub Step1()
'刪除 key word : 公司 / 單別: / 日期* / 產品大類: / 核准 / 合計* / 統計*
Dim reg As Object, a, rng As Range, z&
a = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row).Value
z = UBound(a)
Set rng = Rows(z + 1)
Set reg = CreateObject("vbscript.regexp")
With reg
    .Pattern = "空白|公司|單別:|日期|產品大類:|核准|合計|總計"
    For i = 1 To z
        If Len(a(i, 1)) = 0 Or .test(a(i, 1)) Then
            Set rng = Union(rng, Rows(i))
        End If
    Next
End With
rng.Delete
Set rng = Nothing
End Sub
作者: GBKEE    時間: 2018-2-3 11:32

回復 3# jsc0518
刪除 key word : 公司 / 單別: / 日期* / 產品大類: / 核准 / 合計* / 統計*
.Pattern = "空白|公司|單別:|日期|產品大類:|核准|合計|總計"
沒有一致 有"空白" 當然會刪除
  1. Option Explicit
  2. Sub Step1()
  3.     Dim key_word$, E As Range, Rng As Range
  4.     key_word = "/公司/單別:/日期/產品大類:/核准/合計/統計/"
  5.     For Each E In Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
  6.         If InStr(key_word, "/" & E & "/") Then
  7.             If Rng Is Nothing Then
  8.                 Set Rng = E
  9.             Else
  10.                 Set Rng = Union(Rng, E)
  11.             End If
  12.         End If
  13.     Next
  14.     If Not Rng Is Nothing Then Rng.EntireRow.Delete

  16. End Sub
複製代碼
作者: jsc0518    時間: 2018-2-3 13:08

回復 4# GBKEE
感謝版主的回覆
TEST OK

我再把您分享的VBA語法改成
只要B欄列出現"領料"或是"領用"，就整欄列給予刪除
執行後，B欄列會刪除"領料"或是"領用"
但仍會有一些"領料"或是"領用"的B欄列仍存在，刪除不乾淨
是否哪裡需修訂？
感恩


Sub Step2()
'刪除關鍵字-B欄列--> 領料 領用
    Dim key_word$, E As Range, Rng As Range
    key_word = "/領用/領料/"
    For Each E In Range("b1:b" & Cells(Rows.Count, 1).End(3).Row)
        If InStr(key_word, "/" & E & "/") Then
            If Rng Is Nothing Then
                Set Rng = E
            Else
                Set Rng = Union(Rng, E)
            End If
        End If
    Next
    If Not Rng Is Nothing Then Rng.EntireRow.Delete

End Sub
作者: jsc0518    時間: 2018-2-3 17:18

回復 4# GBKEE
Dear 版主

附檔案[attach]28308[/attach]

執行step2，會有移除不乾淨的畫面
[attach]28309[/attach]

最終的資料是希望
1.可以刪除不必要的欄列
2.另外在A欄下將有空白之欄位其日期自動與上一欄位一樣
[attach]28310[/attach]

謝謝您
作者: GBKEE    時間: 2018-2-3 19:27

回復 6# jsc0518
Step2  應為 2 ->B欄 .1 為A欄
For Each E In Range("b1:b" & Cells(Rows.Count, 1).End(3).Row)
試試看
  1. Option Explicit
  2. Sub Step1()
  3. '刪除關鍵字-A欄列
  4. Dim key_word$, E As Range, Rng As Range
  5. 'key_word = "/公司/單別:/日期:/日期/產品大類:/核准 覆核 單位主管 財會審核 製表人 /合計/合計:/統計/總計:/"
  6. For Each E In ActiveSheet.UsedRange.Columns(1).Cells
  7. If (Not IsDate(E) And E <> "") Or E.Cells(1, 2) <> "" Then
  8. If Rng Is Nothing Then
  9. Set Rng = E
  10. Else
  11. Set Rng = Union(Rng, E)
  12. End If
  13. End If
  14. Next
  15. If Not Rng Is Nothing Then Rng.EntireRow.Delete
  16. For Each E In Range("a1:a" & Cells(Rows.Count, 2).End(xlUp).Row)
  17. If E(1, 3) <> "" And E = "" Then E = E.Cells(0)
  18. Next
  19. If [A1].End(xlDown).End(xlDown).Row <> Rows.Count Then
  20. Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  21. End If
  22. End Sub
複製代碼
作者: jsc0518    時間: 2018-2-3 19:48

回復 7# GBKEE
Deae 版主,
TEST OK，您真的好神歐
真的很感謝您的幫忙！
作者: jsc0518    時間: 2018-2-4 10:28

回復 7# GBKEE
Dear 版主
我用您教導VBA去執行，與我自己用手動刪除後之結果數據有差異

VBA執行後加總J欄位庫存數據
[attach]28315[/attach]
   
手動刪除欄列，加總J欄位庫存數據
[attach]28316[/attach]

附檔案
[attach]28317[/attach]

請幫忙看一下！感恩！
作者: GBKEE    時間: 2018-2-4 12:58

回復 9# jsc0518
你的表格有第一筆資料開始A欄沒有日期所致
試試看
  1. Option Explicit
  2. Sub Step1()
  3.     Dim E As Range, Rng As Range
  4.     For Each E In ActiveSheet.UsedRange.Columns("A:C").Rows
  5.        If (Not IsDate(E.Cells(1)) And E.Cells(1) <> "") Or E.Cells(2) <> "" Or Application.CountA(E.Cells) = 0 Then
  6.             If Rng Is Nothing Then
  7.                 Set Rng = E
  8.             Else
  9.                 Set Rng = Union(Rng, E)
  10.             End If
  11.         End If
  12.     Next
  13.     If Not Rng Is Nothing Then Rng.EntireRow.Delete
  14.     For Each E In Range("a1:a" & Cells(Rows.Count, 2).End(xlUp).Row)
  15.         If E(1, 3) <> "" And E = "" Then E = E.Cells(0)
  16.     Next
  17. End Sub
複製代碼
作者: jsc0518    時間: 2018-2-4 13:19

回復 10# GBKEE
Dear 版主，TEST OK
另外請教一下，哪一段語法是將A欄列日期下空白欄時為自動複製上一欄日期？
作者: GBKEE    時間: 2018-2-4 14:35

回復 11# jsc0518
兩者都可以
  1. With ActiveSheet.UsedRange.Columns("A")
  2.         If .Cells(1).End(xlDown).End(xlDown).Row <> Rows.Count Then  '判斷有空白的儲存格
  3.             .SpecialCells(xlCellTypeBlanks).Cells = "=R[-1]C"                        '沒有空白的儲存格 .SpecialCells(xlCellTypeBlanks) 程式會錯誤
  4.             .Value = .Value
  5.         End If
  6.    End With
複製代碼
  1.     For Each E In ActiveSheet.UsedRange.Columns("A").Cells
  2.         If E(1, 3) <> "" And E = "" Then E = E.Cells(0)      
  3.       'E(1, 3) => E.Cells(1, 3) ,E.Cells(0)=> E.Cells(0, 1) ** 0 -> 上一列
  4.     Next
複製代碼
作者: jsc0518    時間: 2018-2-4 17:16

回復 12# GBKEE
Dear 版主,
謝謝您的指導
作者: jsc0518    時間: 2018-2-6 21:16

回復 12# GBKEE
Dear 版主
抱歉再與您請教一個問題，我想把整理過後之資料copy到另一工作表(這工作表的資料是持續有資料累計的，資料只會變更多)
要怎麼用VBA寫至該工作表
工作表"VBA"從A欄到H欄要COPY到工作表"資料庫"中
*原工作表"資料庫"中的資料仍要保留
   [attach]28328[/attach]
作者: GBKEE    時間: 2018-2-7 08:16

本帖最後由 GBKEE 於 2018-2-8 07:08 編輯

回復 14# jsc0518
  1. Option Explicit
  2. Sub Step1()
  3.     Dim E As Range, Rng As Range
  4.     With Sheets("vba")  'With 陳述式 在一個單一物件或一個使用者自訂型態上執行一系列的陳述式。
  5.         '1*****處理要刪除的列 的迴圈****************
  6.         For Each E In .UsedRange.Columns("A:C").Rows
  7.              'UsedRange 屬性會傳回 Range 物件，此物件代表指定工作表上的已用範圍
  8.             If (Not IsDate(E.Cells(1)) And E.Cells(1) <> "") Or E.Cells(2) <> "" Or Application.CountA(E.Cells) = 0 Then
  9.                 If Rng Is Nothing Then   'Nothing 關鍵字是用來將一個物件變數從一個實際的物件裏分離開來
  10.                    Set Rng = E   'Set(設定變數為物件)  要刪除的列(物件)指定到變數
  11.                 Else    'Not Nothing
  12.                     Set Rng = Union(Rng, E)  'Application.Union 方法 會傳回兩個以上範圍的聯集。
  13.                 End If
  14.             End If
  15.         Next
  16.         If Not Rng Is Nothing Then Rng.EntireRow.Delete   '
  17.             'Range.EntireRow 屬性會傳回 Range 物件，此物件代表包含指定範圍的整個列 (或若干列)。
  18.         '2***********A欄有空白填上日期   *******************************
  19.         For Each E In Range("a1:a" & Cells(Rows.Count, 2).End(xlUp).Row)
  20.             If E(1, 3) <> "" And E = "" Then E = E.Cells(0)
  21.         Next
  22.         '3********指定要複製的範圍*********************************
  23.        Set Rng = .UsedRange   'Sheets("vba")上已使用的範圍為 "A:H"
  24.     End With
  25.     '4**************指定的範圍複製到指定位置 **********************
  26.     With Sheets("資料庫").Range("b1").End(xlDown).Offset(1)
  27.         'Range.End 屬性 傳回 Range 物件，該物件代表包含來源範圍之區域結尾處的儲存格。
  28.         '等於按 END+向上鍵、END+向下鍵、END+向左鍵或 END+向右鍵
  29.    
  30.         'Range.Offset 屬性 會傳回 Range 物件，代表從指定之範圍位移的範圍
  31.         Rng.Copy .Cells
  32.     End With
  33. End Sub
複製代碼
作者: jsc0518    時間: 2018-2-7 20:08

回復 15# GBKEE
Dear 版大您好,
很抱歉一直請教您問題。
您可以幫我單獨寫一個(我想先學習這一部分)

資料copy到另一工作表(這工作表的資料是持續有資料累計的，資料只會變更多)
要怎麼用VBA寫至該工作表
工作表"VBA"從A欄到H欄要COPY到工作表"資料庫"中
*原工作表"資料庫"中的資料仍要保留

檔案如附件

[attach]28344[/attach]
作者: jsc0518    時間: 2018-2-8 13:14

回復 15# GBKEE
Dear 版主,
了解了，剛剛仔細看了VBA語法大概知道哪一段是在做甚麼動作了，感謝您的詳細解說！
作者: jsc0518    時間: 2018-2-8 13:29

回復 16# jsc0518
Dear 版主您好，
我將VBA濃縮成下列說明，想跟您請教一下
1.在工作表"資料庫"B欄~I攔下若有歷史資料時，VBA可以COPY過去
2.在工作表"資料庫"B欄~I攔下若無歷史資料時，會發生錯誤

[attach]28347[/attach]

檔案
[attach]28348[/attach]

VBA 語法

Option Explicit
Sub Step1()
    Dim E As Range, Rng As Range
    With Sheets("vba")  'With 陳述式 在一個單一物件或一個使用者自訂型態上執行一系列的陳述式。
        '3********指定要複製的範圍*********************************
       Set Rng = .UsedRange   'Sheets("vba")上已使用的範圍為 "A:H"
    End With
    '4**************指定的範圍複製到指定位置 **********************
    With Sheets("資料庫").Range("b1").End(xlDown).Offset(1)
        'Range.End 屬性 傳回 Range 物件，該物件代表包含來源範圍之區域結尾處的儲存格。
        '等於按 END+向上鍵、END+向下鍵、END+向左鍵或 END+向右鍵
   
        'Range.Offset 屬性 會傳回 Range 物件，代表從指定之範圍位移的範圍
        Rng.Copy .Cells
    End With
End Sub
作者: GBKEE    時間: 2018-2-8 14:55

回復 18# jsc0518
可改一下
  1. With Sheets("資料庫").Range("b" & Rows.Count).End(xlUp)
  2.         If .Cells = "" Then    '第一列
  3.             Rng.Copy .Cells
  4.         Else
  5.             Rng.Copy .Offset(1)
  6.         End If
  7.     End With
複製代碼
作者: jsc0518    時間: 2018-2-8 17:08

回復 19# GBKEE
Dear 版主,
感謝回復，可以用了，感恩！
作者: jsc0518    時間: 2018-2-12 09:59

回復 19# GBKEE
Dear 版主,
我運用了您所教導的語法，有發生下圖，請問要更改哪一語法呢？
謝謝您!


[attach]28359[/attach]


Option Explicit
Sub Step1()
    Dim E As Range, Rng As Range
    With Sheets("vba")  'With 陳述式 在一個單一物件或一個使用者自訂型態上執行一系列的陳述式。
        '3********指定要複製的範圍*********************************
       Set Rng = .UsedRange   'Sheets("vba")上已使用的範圍為 "A:H"
    End With
    '4**************指定的範圍複製到指定位置 **********************
    With Sheets("資料庫").Range("b" & Rows.Count).End(xlUp)
        If .Cells = "" Then    '第一列
            Rng.Copy .Cells
        Else
            Rng.Copy .Offset(1)
        End If
    End With
End Sub
作者: GBKEE    時間: 2018-2-12 11:23

回復 21# jsc0518
Sub Step1() , Sheets("vba") ,  Sheets("資料庫")
是在同一個 xlsm  嗎?
不是 須指名 Workbooks("xxx").( Sheets("vba") ,  Workbooks("xxx"). Sheets("資料庫")
作者: jsc0518    時間: 2018-2-12 12:55

回復 22# GBKEE
Dear 版主,
我再試試看您所提供的方法
感恩！
作者: jsc0518    時間: 2018-2-12 14:19

回復 22# GBKEE
Dear 版主,
我使用您的VBA做修改"空白欄位可以自動複製與上一筆資料相同"
我把VBA改成B欄時，卻無動作(空白欄位無法自動複製與上一筆資料相同)，是否哪一段語法未修訂？
Thanks!

Sub Step6()
'空白欄位可以自動複製與上一筆資料相同-B
With ActiveSheet.UsedRange.Columns("B")
        If .Cells(1).End(xlDown).End(xlDown).Row <> Rows.Count Then  '判斷有空白的儲存格  !!!!
            .SpecialCells(xlCellTypeBlanks).Cells = "=R[-1]C"                        '沒有空白的儲存格 .SpecialCells(xlCellTypeBlanks) 程式會錯誤
            .Value = .Value
        End If
   End With
End Sub
作者: jsc0518    時間: 2018-2-12 16:39

回復 22# GBKEE
檔案如下
[attach]28365[/attach]
作者: GBKEE    時間: 2018-2-12 18:00

回復 25# jsc0518
一個程式碼並不能通用於所有類似的狀況
附檔中因A欄沒有使用到 ,不適用 ActiveSheet.UsedRange.Columns("B") 為 ActiveSheet的 C 欄
要看你實際上檔案需有所修改,請再附檔看看



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