麻辣家族討論版版 - Powered by Discuz! Board

Sub 移除單號重複()
Set dic = CreateObject("scripting.dictionary")
For i = Range("G65536").End(3).Row To 1 Step -1
If dic.Exists(Cells(i, "G").Value) Then
Rows(i).Delete
Else
dic(Cells(i, "G").Value) = ""
End If
Next i
End Sub

複製代碼

Sub test()
Dim arr()
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 2 To Range("A65536").End(3).Row
If dic.Exists(Cells(i, 1).Value) Then
dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + Cells(i, 5).Value
Else
dic(Cells(i, 1).Value) = Cells(i, 5).Value
n = n + 1
ReDim Preserve arr(1 To 7, 1 To n)
For j = 1 To 7
arr(j, n) = Cells(i, j).Value
Next j
End If
Next i
For i = 1 To n: arr(5, i) = dic(arr(1, i)): Next i
Columns("I:O").ClearContents
[I1].Resize(1, 7) = [A1].Resize(1, 7).Value
[I2].Resize(n, 7) = Application.Transpose(arr)
End Sub

複製代碼

ReDim Preserve arr(1 To 7, 1 To n)
For j = 1 To 7
arr(j, n) = Cells(i, j).Value
Next j

複製代碼

Option Explicit
Sub Ex()
Dim r As Integer, Ar(), i As Integer
'*******前置作業
With Range("A:A").CurrentRegion
'CurrentRegion :目前區域,是指以任意空白列及空白欄的組合為邊界的範圍
.Sort key1:=.Cells(1), order1:=xlAscending, key2:=.Cells(4), order1:=xlAscending, header:=xlYes '排序
.Columns(1).AdvancedFilter ACTION:=xlFilterCopy, COPYTORANGE:=Cells(1, Columns.Count), Unique:=True
'進階篩選:進階不重複資料,至於工作表的最右邊的欄位
End With
'************************
r = Cells(Rows.Count, Columns.Count).End(xlUp).Row '計算篩選資料數 (客戶編號)
ReDim Ar(1 To r) '重置陣列大小為 (客戶編號)個數
Ar(1) = Application.Transpose(Application.Transpose(Range("A1").Resize(, 6))) '表頭置入陣列
For i = 2 To r '迴圈 (客戶編號)
With Range("A:A")
.Replace Cells(i, Columns.Count), "=1/0" '將 (客戶編號) 改為錯誤值
With .SpecialCells(xlCellTypeFormulas, xlErrors).Resize(, 6) '錯誤值的範圍
.Columns(1) = Cells(i, Columns.Count) ' '將錯誤值改回原客戶編號
Ar(i) = Array(.Cells(1).Value, .Cells(2).Value, .Cells(3).Value, .Cells(4).Value, Application.Sum(.Columns(5)), .Cells(.Rows.Count, 6).Value) 'Application.Sum(.Columns(5)) 加總(客戶編號)的CASH
End With
End With
Next
With Range("I1")
.Resize(r, 6).EntireColumn = "" '清除舊有資料
.Resize(r, 6) = Application.Transpose(Application.Transpose(Ar)) '範圍內導入轉置2次的陣列
End With
Cells(1, Columns.Count).EntireColumn = "" '清除舊有資料
End Sub
'*********************************************************************
Sub Ex1()
Dim Rng As Range, Ar(), i As Integer
'*******前置作業
With Range("A:A").CurrentRegion
'CurrentRegion :目前區域,是指以任意空白列及空白欄的組合為邊界的範圍
.Sort key1:=.Cells(1), order1:=xlAscending, key2:=.Cells(4), order1:=xlAscending, header:=xlYes '排序
End With
'************************
i = 1
ReDim Ar(1 To i) '重置陣列大小為 (客戶編號)個數
Ar(1) = Application.Transpose(Application.Transpose(Range("A1").Resize(, 6))) '表頭置入陣列
Set Rng = Range("A2")
Do While Rng <> "" '客戶編號 <> ""
i = i + 1
ReDim Preserve Ar(1 To i)
With Rng
Ar(i) = Array(.Cells(1).Value, .Cells(1, 2).Value, .Cells(1, 3).Value, .Cells(1, 4).Value, .Cells(1, 5).Value, .Cells(.Rows.Count, 6).Value)
End With
Do While Rng = Rng.Offset(1) '同一 (客戶編號)
Ar(i)(4) = Ar(i)(4) + Rng.Cells(1, 5) '加總同一 (客戶編號)的CASH
Ar(i)(5) = Rng.Cells(2, 6)
Set Rng = Rng.Offset(1) '下一個客戶編號
Loop
Set Rng = Rng.Offset(1) '下一個客戶編號
Loop
With Range("I1")
.Resize(, 6).EntireColumn = "" '清除舊有資料
.Resize(i, 6) = Application.Transpose(Application.Transpose(Ar)) '範圍內導入轉置2次的陣列
End With
End Sub

複製代碼

Sub UseFind()
Dim cell As Range
Columns("I:O").ClearContents
[I1].Resize(1, 7) = [A1].Resize(1, 7).Value
er = 2
For i = 2 To Range("A65536").End(3).Row
Set cell = Columns(9).Find(Cells(i, 1).Value, lookat:=xlWhole)
If cell Is Nothing Then
Cells(er, 9).Resize(1, 7) = Cells(i, 1).Resize(1, 7).Value
er = er + 1
Else
Cells(cell.Row, 13).Value = Cells(cell.Row, 13).Value + Cells(i, 5).Value
End If
Next i
End Sub

複製代碼