Sub RunMe() Dim ws As Worksheet Dim mFind As Range With Sheets("Sheet6") .Range("A2:E" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents For Each ws In Worksheets ws.Select If ws.Name <> "Sheet6" Then ws.Range("A2:D" & ws.Range("A" & Rows.Count).End(xlUp).Row).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1) End If Next ws .Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes .Select For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) For Each ws In Worksheets ws.Select If ws.Name <> "Sheet6" Then Set mFind = Columns("A:A").Find(cell.Value) If Not mFind Is Nothing Then If ws.Name = "Sheet3" Or ws.Name = "Sheet4" Then .Range("E" & cell.Row).Value = .Range("E" & cell.Row).Value - mFind.Offset(0, 4).Value Else .Range("E" & cell.Row).Value = .Range("E" & cell.Row).Value + mFind.Offset(0, 4).Value End If End If End If Next ws Next cell End With End Sub
Sub alhagag() Dim Ary As Variant Dim Dic As Object Dim i As Integer Dim Cl As Range Set Dic = CreateObject("scripting.dictionary") Ary = Array("sheet1", "sheet2", "Sheet5", "sheet3", "sheet4") For i = 0 To UBound(Ary) With Sheets(Ary(i)) .Range("A2:E" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Sheets("Sheet6").Range("A" & Rows.Count).End(xlUp).Offset(1) End With Next i With Sheets("Sheet6") .Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp)) Dic.Item(Cl.Value) = Cl.Offset(, 4).Value Next Cl End With For i = 1 To UBound(Ary) With Sheets(Ary(i)) For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp)) If Dic.Exists(Cl.Value) Then Dic.Item(Cl.Value) = IIf(i < 3, Dic.Item(Cl.Value) + Cl.Offset(, 4), Dic.Item(Cl.Value) - Cl.Offset(, 4)) Next Cl End With Next i Sheets("Sheet6").Range("e2").Resize(Dic.Count).Value = Application.Transpose(Dic.items) End Sub
Sub RunMe() Dim ws As Worksheet Dim mFind As Range With Sheets("sheet6") .Range("A2:E" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents For Each ws In Worksheets ws.Select If ws.Name <> "sheet6" Then ws.Range("A2:D" & ws.Range("A" & Rows.Count).End(xlUp).Row).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1) End If Next ws .Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) For Each ws In Worksheets ws.Select If ws.Name <> "sheet6" Then Set mFind = Columns("A:A").Find(cell.Value) If Not mFind Is Nothing Then If ws.Name = "sheet3" Or ws.Name = "sheet4" Then .Range("E" & cell.Row).Value = .Range("E" & cell.Row).Value - mFind.Offset(0, 4).Value Else .Range("E" & cell.Row).Value = .Range("E" & cell.Row).Value + mFind.Offset(0, 4).Value End If End If End If Next ws Next cell End With End Sub
DON'T MISS