|
练手而已。。。
- Sub 按客户名称拆分() '//2024.3.23
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Dim t: t = Timer
- Dim d As Object, rng As Range
- Set d = CreateObject("scripting.dictionary")
- Set ws = ThisWorkbook
- p = ThisWorkbook.Path & ""
- For Each sht In ws.Sheets
- arr = sht.UsedRange
- c = Application.WorksheetFunction.Match("客户名称", sht.Rows(1), 0)
- For i = 2 To UBound(arr)
- s = Trim(arr(i, c))
- If s <> "" Then
- d(s) = ""
- End If
- Next i
- Next sht
- For Each k In d.keys
- ws.Sheets.Copy
- Set wb = ActiveWorkbook
- For Each sht In Sheets
- With sht
- arr = .UsedRange
- c = Application.WorksheetFunction.Match("客户名称", sht.Rows(1), 0)
- .DrawingObjects.Delete
- For i = 2 To UBound(arr)
- If Trim(arr(i, c)) <> k Then
- If rng Is Nothing Then
- Set rng = .Rows(i)
- Else
- Set rng = Union(rng, .Rows(i))
- End If
- End If
- Next i
- If Not rng Is Nothing Then rng.Delete
- Set rng = Nothing
- End With
- Next
- wb.SaveAs p & k
- wb.Close
- Next k
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- MsgBox "拆分完毕,共用时: " & Format(Timer - t, "0.000秒"), , "提示"
- End Sub
复制代码
|
评分
-
1
查看全部评分
-
|