- 帖子
- 75
- 主題
- 8
- 精華
- 0
- 積分
- 109
- 點名
- 0
- 作業系統
- windows XP
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 高雄
- 註冊時間
- 2015-4-19
- 最後登錄
- 2024-8-10
|
25#
發表於 2019-10-10 11:44
| 只看該作者
回復 24# cclo0728
Sub 各別將廠商分頁()
f1 = Sheets.Count '判斷現在有幾頁
ROW1 = Cells(Rows.Count, "A").End(3).Row
If ROW1 > 2 Then
Range(Cells(1, "A"), Cells(ROW1, "B")).Clear
End If
If f1 > 3 Then '判斷頁面大於3頁 表示有原來的資料 刪除
For i = f1 To 4 Step -1 '從最後一頁往前 刪除
Application.DisplayAlerts = False '關閉提醒
Sheets(i).Delete
Application.DisplayAlerts = True '開啟提醒
Next
End If
ROW1 = Sheets("欠料").Cells(Rows.Count, "C").End(3).Row
Sheets("欠料").Range("B1:B" & ROW1).Copy Range("A1")
Range("B2:B" & ROW1) = "=COUNTIF(A:A,A2)"
Range("B2:B" & ROW1).Value = Range("B2:B" & ROW1).Value
'排序 大到小============
ActiveWorkbook.Worksheets("更新2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("更新2").Sort.SortFields.Add Key:=Range("B2:B" & ROW1), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("更新2").Sort
.SetRange Range("A1:B" & ROW1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'移除重複========================
ActiveSheet.Range("$A$1:$B$" & ROW1).RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
ROW1 = Cells(Rows.Count, "A").End(3).Row
arr = Range("A2:B" & ROW1)
ROW2 = Sheets(1).Cells(Rows.Count, "A").End(3).Row
'新增頁面==============================
For i = 1 To UBound(arr)
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(i + 3).Name = arr(i, 1)
Range("A1").Value = "客戶簡稱"
Range("A2").Value = arr(i, 1)
ROW3 = Cells(Rows.Count, "A").End(3).Row
'進階篩選===============================
Sheets(1).Range("A1:AA" & ROW2).AdvancedFilter _
Action:=xlFilterCopy, CriteriaRange:=Range("A1:A" & ROW3), CopyToRange:=Range( _
"C1"), Unique:=False
Range("A:B").Delete
Next
Sheets("更新2").Select
ROW3 = Cells(Rows.Count, "A").End(3).Row
Range(Cells(1, "A"), Cells(ROW3, "B")).Clear
End Sub
 公式1.zip (51.32 KB)
|
|
