EXCEL _ VBA資料拆解

Sub 資料比對()


Dim my_rng, my_end

Sheets.Add

Workbooks.Open Filename:="T2 Digit Code.xls"

my_end = ActiveCell.SpecialCells(xlLastCell).Row

my_rng = "C4:C" & my_end

Range(my_rng).Select

Selection.Copy

Windows("FW11 2nd CUST FCST - 021210.xls").Activate

ActiveSheet.Paste

Application.CutCopyMode = False

Windows("T2 Digit Code.xls").Close

刪除空白

End Sub



Sub 刪除空白()

Dim my_start, my_end

my_end = ActiveCell.SpecialCells(xlLastCell).Row



For i = 1 To my_end



If ActiveCell.Value <> Empty Then

ActiveCell.Offset(1, 0).Select

Else





Selection.Delete Shift:=xlUp



End If

Next



Range("A1").Select



End Sub



Sub 合併篩選()

Dim my_rng, i, y

Sheets(1).Select

y = ActiveCell.SpecialCells(xlLastCell).Row

For i = 1 To y

my_rng = "A" & i

' 資料移轉

Sheets(Sheets.Count).Select

Range("A1").Select

Selection.AutoFilter

Selection.AutoFilter Field:=2, Criteria1:=Sheets(1).Range(my_rng).Value

Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

Selection.Copy

'新活頁簿

Workbooks.Add

ActiveSheet.Paste

Application.CutCopyMode = False

If Range("A2").Value <> Empty Then



'儲存活頁簿

x = Range("c2").Value

ActiveWorkbook.SaveAs Filename:= _

x & ".xls", FileFormat:= _

xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _

, CreateBackup:=False

'關閉活頁簿

ActiveWindow.Close

Else

Application.DisplayAlerts = False

ActiveWorkbook.Close

End If





' 結束篩選

Sheets(Sheets.Count).Select

Range("A1").Select

Selection.AutoFilter



Next



End Sub