- 帖子
- 3
- 主題
- 1
- 精華
- 0
- 積分
- 5
- 點名
- 0
- 作業系統
- Windows7
- 軟體版本
- Office2010
- 閱讀權限
- 10
- 性別
- 男
- 註冊時間
- 2016-10-13
- 最後登錄
- 2016-12-16
|
- Sub 巨集1()
- ' Timing
- Dim Time0#
- Time0 = Timer
-
- ' Close screenupdating to boost the procedure
- Application.ScreenUpdating = False
-
- ' Import XML data (cms_info)
- ActiveWorkbook.XmlImport URL:= _
- "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\cms_info_0000.xml", ImportMap:= _
- Nothing, Overwrite:=True, Destination:=Range("$A$1")
- ActiveWorkbook.XmlMaps("XML_Head_Map").Name = "XML_Head_Map_Info"
-
- ' Import another XML data (cms_value)
- Sheets("工作表2").Select
-
- ActiveWorkbook.XmlImport URL:= _
- "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\cms_value_0000.xml", ImportMap:= _
- Nothing, Overwrite:=True, Destination:=Range("$A$1")
-
- ' Delete unnecessary data
- Columns("A:B").EntireColumn.Delete
- Columns("B:B").EntireColumn.Delete
- Columns("C:C").EntireColumn.Delete
- ' Setting the succeeding import default
- With ActiveWorkbook.XmlMaps("XML_Head_Map")
- .ShowImportExportValidationErrors = False
- .AdjustColumnWidth = True
- .PreserveColumnFilter = True
- .PreserveNumberFormatting = True
- .AppendOnImport = False
- End With
- ' Deal with the string
- [D1].FormulaR1C1 = "全形轉半形"
- [D2].FormulaR1C1 = "=ASC([@message])"
- Columns("D:D").ColumnWidth = 41
-
- [E1].FormulaR1C1 = "含關鍵字與否"
- [E2].FormulaR1C1 = _
- "=IF(COUNTIF([@message],""*壅塞*"")+COUNTIF([@message],""*K*"")+COUNTIF([@message],""*k*"")+COUNTIF([@message],""*雨*"")+COUNTIF([@message],""*天候不佳*""),1,0)"
-
- ' Find dest
- 'Dim dest&, count&
- Count = 1
- [F2].FormulaR1C1 = "=SUM([含關鍵字與否])"
- Count = [F2].Value
- Columns("F:F").EntireColumn.Delete
- dest = Count + 1
- 'MsgBox (dest)
- ' Filter
- Dim i&, LR&
- 'dest = [F1].Value
- 'MsgBox (dest)
- Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5, Criteria1:="1"
- LR = Range("A" & Rows.Count).End(xlUp).Row
- Range("A1:P" & LR).SpecialCells(xlCellTypeVisible).Select
- Selection.Copy
- Sheets("工作表3").Range("A1").PasteSpecial xlPasteValues
- Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5
- sPath = "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\"
- sFile = Dir(sPath & "*.xml")
- 'MsgBox (sFile)
- i = 1
- Do While sFile <> ""
- If sFile <> "cms_info_0000.xml" And sFile <> "cms_value_0000.xml" Then
- ActiveWorkbook.XmlMaps("XML_Head_Map").Import URL:= _
- sPath & sFile
- If [A3].Value <> "" Then
- '動態處理
- [F2].FormulaR1C1 = "=SUM([含關鍵字與否])"
- Count = [F2].Value
- Columns("F:F").EntireColumn.Delete
- dest = dest + 1
- Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5, Criteria1:="1"
- LR = Range("A" & Rows.Count).End(xlUp).Row
- Range("A2:P" & LR).SpecialCells(xlCellTypeVisible).Select
- Selection.Copy
- Sheets("工作表3").Range("A" & dest).PasteSpecial xlPasteValues
- dest = dest + Count - 1
- Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5
- End If
- End If
- sFile = Dir()
- i = i + 1
- Loop
-
- ' Parameterize/ Structure the sheet
- Sheets("工作表3").Select
- ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$E$" & dest), , xlYes).Name = "表格3"
-
- Application.ScreenUpdating = True
- MsgBox "執行時間 " & Timer - Time0 & " 秒", vbOKOnly
- End Sub
關掉screenupdating以及減少selection的使用
加上將匯入資料篩選想要資料後貼至新表格，而非在原表格篩選出不要資料刪除
速度快了非常多，約 1分半內跑完一整天的資料
目前遇到的問題是selection後的value想用transfer而非copy和paste的方式不知道怎麼處理
雖然不知道速度會再快多少，但目前結果算差強人意了
與大家分享，若有建議還請不吝提出，謝謝！ |
|
發表於 2016-11-3 18:03
| 
