[發問] 依照標題關鍵字指定欄位條件而刪除該攔

billchenfantasy

請問
Sub 按鈕1_Click()
Dim uFile$
Dim rng As Range
ChDrive "C:\"
ChDir "C:\Users\us\Desktop\"
Source = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xlsx")
With Workbooks.Open(Source)
For i = 1 To ActiveWorkbook.Sheets.Count
.Sheets(i).Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
Next i
.Close
End With
以下是將完全符合"PLAN_NO", "PlAN_DAT"的標題其欄位刪去，但因為有些欄位具有PLAN_NO_1,PLAN_NO_2......請問要如何修改成符合關鍵字"PLAN_NO", "PlAN_DAT"的欄位刪去的寫法
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
For j = 1 To .[A1].CurrentRegion.Columns.Count
If IsError(Application.Match(.Cells(1, j).Value, Array("section", "PLAN_NO", "PlAN_DAT"), 0)) Then
If rng Is Nothing Then Set rng = .Columns(j) Else Set rng = Union(rng, .Columns(j))
End If
Next j
.Range(rng.Address).Delete Shift:=xlToLeft
Set rng = Nothing
End With

End Sub

billchenfantasy

對不起我打錯了改成"以下是將完全符合"PLAN_NO", "PlAN_DAT"的標題以外的其他欄位刪去，但因為有些欄位具有PLAN_NO_1,PLAN_NO_2......請問要如何修改成符合關鍵字"PLAN_NO", "PlAN_DAT"的欄位留下其他刪去的寫法

oobird

If IsError(Application.Match(.Cells(1, j).Value, Array("section", "PLAN_NO", "PlAN_DAT"), 0)) Then
改成
if .cells(1,j) like "PLAN_NO*" or  .cells(1,j) like "PlAN_DAT*" then

billchenfantasy

首先謝謝您的回答~改完程式可以跑~但是沒有成功刪除@@~以下是我CO的前面幾個欄位標題
(FID_plan0) (PLAN_AREA)  (PLAN_NO) (PLAN_NAME) (PLAN_DATE) (FID_plan01) (Plan_Are_1) (Plan_No_1) (Plan_Nam_1) (Plan_Dat_1) (FID_plan2) (PLAN_ARE_2) (PLAN_NO_2)  (Plan_Nam_2)( (PLAN_DAT_2)
要怎麼改寫才能把
(PLAN_NO) (PLAN_DATE) (Plan_No_1) (Plan_Dat_1) (PLAN_NO_2) ) (PLAN_DAT_2)
欄位留下，其他的欄位刪除呢?

billchenfantasy

回復 3# oobird

首先謝謝您的回答~改完程式可以跑~但是沒有成功刪除@@~以下是我CO的前面幾個欄位標題
(FID_plan0) (PLAN_AREA)  (PLAN_NO) (PLAN_NAME) (PLAN_DATE) (FID_plan01) (Plan_Are_1) (Plan_No_1) (Plan_Nam_1) (Plan_Dat_1) (FID_plan2) (PLAN_ARE_2) (PLAN_NO_2)  (Plan_Nam_2)( (PLAN_DAT_2)
要怎麼改寫才能把
(PLAN_NO) (PLAN_DATE) (Plan_No_1) (Plan_Dat_1) (PLAN_NO_2) ) (PLAN_DAT_2)
欄位留下，其他的欄位刪除呢?

Hsieh

回復 5# billchenfantasy

1. Sub ex()
   
2. Dim Rng As Range, C As Range
   
3. ar = Array("PLAN_NO", "PlAN_DAT")
   
4. For Each C In Rows(1).SpecialCells(xlCellTypeConstants)
   
5. n = 0
   
6.    For Each a In ar
   
7.      If InStr(UCase(C), UCase(a)) > 0 Then
   
8.      n = n + 1
   
9.      End If
   
10.      If n = 0 Then
    
11.         If Rng Is Nothing Then
    
12.            Set Rng = C
    
13.            Else
    
14.            Set Rng = Union(Rng, C)
    
15.         End If
    
16.      End If
    
17.   Next
    
18. Next
    
19. Rng.EntireColumn.Delete
    
20. End Sub

複製代碼

billchenfantasy

回復 6# Hsieh
@@感謝您的答覆，以下是我依據您的撰寫組合而成的需求，運行正常，"PLAN_NO"可被篩出但維"PLAN_DAT"無法判別出來
Sub 按鈕1_Click()
    Dim uFile$
    Dim Rng As Range, C As Range
    ChDrive "C:\"
    ChDir "C:\Users\us\Desktop\"
    Source = Application.GetOpenFilename(FileFilter:="Excel Files (*xlsm.),*.xlsm")
    With Workbooks.Open(Source)
    For i = 1 To ActiveWorkbook.Sheets.Count
        .Sheets(i).Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
    Next i
    .Close
End With

ar = Array("PLAN_NO", "PLAN_DAT")
For Each C In Rows(1).SpecialCells(xlCellTypeConstants)
n = 0
   For Each a In ar
     If InStr(UCase(C), UCase(a)) > 0 Then
     n = n + 1
     End If
     If n = 0 Then
        If Rng Is Nothing Then
           Set Rng = C
           Else
           Set Rng = Union(Rng, C)
        End If
     End If
  Next
Next
Rng.EntireColumn.Delete
End Sub
以上結果為(PLAN_NO) (Plan_No_1) (PLAN_NO_2) 而非
(PLAN_NO) (PLAN_DATE) (Plan_No_1) (Plan_Dat_1) (PLAN_NO_2) (PLAN_DAT_2)還請問如何修改感謝您

billchenfantasy

回復 7# billchenfantasy
修改前原始資料.rar (10.58 KB)

此為原始格式
下載次數: 4

2013-2-18 11:03

以上為原始格式資料感恩~

Hsieh

回復 8# billchenfantasy
第17行的Next要往前放

1. Sub ex()
   
2. 
   
3. Dim Rng As Range, C As Range
   
4. ar = Array("PLAN_NO", "PLAN_DAT")
   
5. For Each C In Rows(1).SpecialCells(xlCellTypeConstants)
   
6. n = 0
   
7.    For Each a In ar
   
8.      If InStr(UCase(C), UCase(a)) > 0 Then
   
9.      n = n + 1
   
10.      End If
    
11.    Next
    
12.      If n = 0 Then
    
13.         If Rng Is Nothing Then
    
14.            Set Rng = C
    
15.            Else
    
16.            Set Rng = Union(Rng, C)
    
17.         End If
    
18.      End If
    
19. Next
    
20. Rng.EntireColumn.Delete
    
21. End Sub

複製代碼

billchenfantasy

回復 9# Hsieh
= =原來如此，剛剛使用後程式成功運作~感謝您~