[發問] 排序後刪除特定攔位

billchenfantasy

下載 (68.14 KB)

2013-1-22 15:53

呈上資料頁面，請問如果我要先以land_no_m和land_no_c兩攔為準做排序之後保留以下這九個欄位其他刪除該怎麼撰寫VBA呢~感謝
(section) (SC) (LANDUSE)  (PUBNO)        (OPTION)        (METHOD)        (MUPLAN)        (DUPLAN)        (ORG_FID)

下載 (20.85 KB)

2013-1-22 16:05

stillfish00

回復 12# billchenfantasy
恩 試了一下  #10 的兩行順序調換
結果應該跟 #11 一樣

billchenfantasy

@@是的每張欄位格式都是一樣的，所以land_no_m, land_no_c 每張表都有，只有少數才有多一行的狀況才會想說指定欄位，感謝您的再度協助

stillfish00

回復 10# billchenfantasy
land_no_m, land_no_c 每張表都有嗎?

1.     If Not (IsError(Application.Match("land_no_m", .Rows(1), 0)) Or _
   
2.             IsError(Application.Match("land_no_c", .Rows(1), 0))) Then
   
3.         .[A1].CurrentRegion.Sort Key1:=.Columns(Application.Match("land_no_m", .Rows(1), 0)), _
   
4.                                     Order1:=xlAscending, _
   
5.                                     Key2:=.Columns(Application.Match("land_no_c", .Rows(1), 0)), _
   
6.                                     Order2:=xlAscending, _
   
7.                                     Header:=xlYes
   
8.     Else
   
9.         MsgBox .Sheets(i).Name & " : Sorting field not found."
   
10.     End If

複製代碼

billchenfantasy

遇到問題了@@如果需要以land_no_m為KEY1與land_no_c為KEY2去做排序以下排序的程序該如何修改ㄋ

If Not IsError(Application.Match("land_no_m", .Rows(1), 0)) Then .[A1].CurrentRegion.Sort Key1:=.Columns(Application.Match("land_no_m", .Rows(1), 0)), Order1:=xlAscending, Header:=xlYes

  If Not IsError(Application.Match("land_no_c", .Rows(1), 0)) Then .[A1].CurrentRegion.Sort Key1:=.Columns(Application.Match("land_no_c", .Rows(1), 0)), Order1:=xlAscending, Header:=xlYes

billchenfantasy

感激~註解詳細~感覺上了一課@@謝謝您的解答

stillfish00

回復 7# billchenfantasy

1. Private Sub CommandButton1_Click()
   
2. Dim Source, f
   
3. Dim rng As Range
   
4. 
   
5. '可選擇多個檔案
   
6. Source = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx),*.xls;*.xlsx", _
   
7.                                     MultiSelect:=True)
   
8. If TypeName(Source) = "Boolean" Then If Source = False Then Exit Sub
   
9. 
   
10. For Each f In Source
    
11. '開啟檔案/活頁簿
    
12. With Workbooks.Open(f)
    
13.     '對所有工作表
    
14.     For i = 1 To ActiveWorkbook.Sheets.Count
    
15.         '複製工作表到本活頁簿
    
16.         .Sheets(i).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
17.         '本活頁簿中該工作表
    
18.         With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
19.            '依land_no_m, land_no_c欄排序
    
20.             If Not IsError(Application.Match("land_no_m", .Rows(1), 0)) Then .[A1].CurrentRegion.Sort Key1:=.Columns(Application.Match("land_no_m", .Rows(1), 0)), Order1:=xlAscending, Header:=xlYes
    
21.             If Not IsError(Application.Match("land_no_c", .Rows(1), 0)) Then .[A1].CurrentRegion.Sort Key1:=.Columns(Application.Match("land_no_c", .Rows(1), 0)), Order1:=xlAscending, Header:=xlYes
    
22.             
    
23.             '找出不符合的欄
    
24.             For j = 1 To .[A1].CurrentRegion.Columns.Count
    
25.                 If IsError(Application.Match(.Cells(1, j).Value, Array("section", "SC", "LANDUSE", "PUBNO", "OPTION", "METHOD", "MUPLAN", "DUPLAN", "ORG_FID"), 0)) Then
    
26.                     If rng Is Nothing Then Set rng = .Columns(j) Else Set rng = Union(rng, .Columns(j))
    
27.                 End If
    
28.             Next j
    
29.             '刪除
    
30.             .Range(rng.Address).Delete shift:=xlToLeft
    
31.             Set rng = Nothing
    
32.         End With
    
33.     Next i
    
34.     '關閉檔案
    
35.     .Close
    
36. End With
    
37. Next f
    
38. End Sub

複製代碼

billchenfantasy

感謝stillfish00 這對我這菜鳥來說，看起來簡直是變魔術，感恩，是您的匯入方式比較合理，
.Range("A:C,E:I,K,Q").Delete Shift:=xlToLeft是直接選定欄位
最後一個問題是所謂"刪除特定攔位"可以是指定保留(section) (SC) (LANDUSE) (PUBNO) (OPTION) (METHOD) (MUPLAN) (DUPLAN) (ORG_FID)標題的一整個欄位，其他無論甚麼標題的欄位都刪掉的寫法嗎(用以確保批次時某一個檔的例外多一條無須保留的攔位)

stillfish00

回復 5# billchenfantasy
同一活頁簿是不能有多個相同名稱的工作表

你要的批次處理是這樣嗎? (可選多個檔案)

1. Private Sub CommandButton1_Click()
   
2. Dim Source, f
   
3. 
   
4. '可選擇多個檔案
   
5. Source = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx),*.xls;*.xlsx", _
   
6.                                     MultiSelect:=True)
   
7. If TypeName(Source) = "Boolean" Then If Source = False Then Exit Sub
   
8. 
   
9. For Each f In Source
   
10. '開啟檔案/活頁簿
    
11. With Workbooks.Open(f)
    
12.     '對所有工作表
    
13.     For i = 1 To ActiveWorkbook.Sheets.Count
    
14.         '複製工作表到本活頁簿
    
15.         .Sheets(i).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
16.         '本活頁簿中該工作表
    
17.         With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
18.            '依E,F欄排序
    
19.            .[A1].CurrentRegion.Sort Key1:=.[E:E], Order1:=xlAscending, _
    
20.                                     Key2:=.[F:F], Order2:=xlAscending, _
    
21.                                     Header:=xlYes
    
22.            '刪除不要的欄
    
23.            .Range("A:C,E:I,K:L,Q:Q").Delete Shift:=xlToLeft
    
24.         End With
    
25.     Next i
    
26.     '關閉檔案
    
27.     .Close
    
28. End With
    
29. Next f
    
30. End Sub

複製代碼

billchenfantasy

@@Private Sub CommandButton2_Click()
的OK了對於您的解答感謝萬分，我來好好研究一下
Private Sub CommandButton1_Click()的意思是說
"複製工作表過來時名字應該是和原本工作表一樣的"沒錯
因為我的檔案有很多，而且雖然內容格式一樣但檔名不一樣，我的想法是要怎麼樣
把不同檔名的檔案匯進來之後都可以執行Private Sub CommandButton2_Click()，
因為指定的With Sheets("工作表名稱")工作表名稱會變
等這個都了解了接下來再想下一步怎麼批次
再次謝謝你歐