2,464
社区成员
发帖
与我相关
我的任务
分享
Option Explicit
Sub merget()
Application.ScreenUpdating = False
Dim dic As Object
Dim rng As Range
Set dic = CreateObject("scripting.dictionary")
Set rng = Worksheets("Sheet1").UsedRange
Dim i As Integer, j As Integer
Dim key As String
Dim row As Integer, krow As Integer
row = 1
Dim findStr As Integer
For i = 1 To rng.Rows.Count
key = rng.Cells(i, 1).Value & rng.Cells(i, 6).Value
'Debug.Print key
If key = "" Then GoTo LINE
If (dic.exists(key)) Then
krow = dic(key)
Cells(krow, 2).Value = Val(Cells(krow, 2).Value) + Val(rng(i, 2).Value)
Cells(krow, 3).Value = Val(Cells(krow, 3).Value) + Val(rng(i, 3).Value)
findStr = InStr(Cells(krow, 7).Value, rng(i, 7).Value)
If findStr = 0 Then
If StrComp(Cells(krow, 7).Value, rng(i, 7).Value) < 0 Then
Cells(krow, 7).Value = Cells(krow, 7).Value & "/" & rng(i, 7).Value
Else
Cells(krow, 7).Value = rng(i, 7).Value & "/" & Cells(krow, 7).Value
End If
End If
Else
dic.Item(key) = row
rng(i, 1).Resize(1, 7).Copy
Range(Cells(row, 1), Cells(row, 7)).PasteSpecial xlPasteValuesAndNumberFormats
row = row + 1
End If
LINE:
Next i
Application.ScreenUpdating = True
End Sub