hi,
i search so much in the internet to fix my code to work but no answering so far i have 6 sheets it suppose copying data from a2:e among 5 sheets and result shows in sheet6 but the column e among sheets it summing and subtracting for in stance the code aa =150+150-150-150+150=150 as in the image i hope somebody help
Sub alhagag() Dim Ary As Variant Dim Dic As Object Dim i As Long Dim Cl As Range
Set Dic = CreateObject("scripting.dictionary") Ary = Array("sheet1", "sheet2", "Sheet5", "sheet3", "sheet4") With Sheets(Ary(0)) .Range("A2:e" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Sheets("Sheet6").Range("A" & Rows.Count).End(xlUp).Offset(1) End With With Sheets("Sheet6") 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 < 4, 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
you can see the result should be sheet6 colored by green
The code below will:
- clear the table from sheet 6.
- copy every table from sheets 1 to 5, to sheet 6.
- remove duplicates from sheet 6 based on the values in column A.
- loop through sheets 1 to 5 and adds the value from column E to the corresponding values of sheet 6 column E, where sheets 3 and 4 are negative values.
Here is the code:
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
I'm not familiar with your situation, so I'm not sure why you want to handle your query like this.
By that I mean: Copy all values from sheet 1 to sheet 6 and then skip those values in your calculation. That way the ff value from sheet 2 is skipped.
I adjusted the code to get as close to the result as possible, but since the ff value is not on sheet 1 it is calculated twice.
Here is the code:
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
In your posted workbook all Column A values are the same, thus the result sheet (sheet 6) will have the correct result.
When sheet 6 is empty, except for the header, then the values in column D will be Sheet1+Sheet2-Sheet3-Sheet4+Sheet5. I don't understand why you say the problem is still there. Maybe you didn't clear the previous results, in which case the result will be doubled.
I'll get back to you next week, to provide you with a code, that also works with your sample data from your first post.
You don't have to clear your data, the code will do it for you.
I did notice that your sheet names didn't start with an upper case as they do in my testbook. I adjusted the code, put it in your workbook and it works fine.
Just to check: the value for AA1 = 250 + 120 - 50 - 50 + 50 = 320 in sheet6.
now your adjusting more efficient but if is possible when i add a new data ,i wouldn't sum values and subtract again to old data every time i add a new data just do that one time when i add a new time it ignores summing and subtracting to old data
I'm really sorry if i make you confusing , your adjusting works as what i want let me explain more i suppose there is no data now i fill data this is the first time, works ok and i enter data every day , so not subtract and sum the entered old data again
only entered a new data it supposes summing and subtracting to be one time ,every data entered it is not reasonable to sum and subtract twice for the values of entered old brand
The results won't be calculated more then ones, because the results are cleared every time the code is run (=activated, i.e. when you click the button).
Do you maybe mean that column A can have duplicates upon a new entry? For example on sheet1 column A you have values: AA1, AA2, BB1, BB2 and the next day you might enter a new row of data with AA1 in column A.
hi TrowaD
for more explenation here capture two images the imege 1 shows values of data in sheet6 is right when i run code first time and if i run macro again it changes the values it supposes stay the values according image 1
image1
This doesn't happen to me. Are you sure you are running the right code?
The right code:
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
When you get the same result, can you then upload your file so I can see what you did differently?
