separation of data

[alireza123456]

Hi
I have a large number of factory data in different sheets and wish separate a specified factory data. please guide me.
for example:
sheet1:

factory	sale	income	work day
a	10	200	5
b	20	300	6
c	15	300	5
d	5	500	4

<colgroup><col width="70" span="4" style="width:53pt"> </colgroup><tbody>
</tbody>

sheet2:

factory	sale	income	work day
b	10	100	3
d	12	500	4
a	14	200	5
f	13	300	6
h	10	400	5

<colgroup><col width="70" span="4" style="width:53pt"> </colgroup><tbody>
</tbody>

sheet 3:

factory	sale	income	work day
a	10	200	5
c	20	300	4
f	30	400	6
a	5	200	5

<colgroup><col width="70" span="4" style="width:53pt"> </colgroup><tbody>
</tbody>

i want:

factory	sale	income	work day
a	10	200	5
a	14	200	5
a	10	200	5
a	5	200	5

<colgroup><col width="70" span="4" style="width:53pt"> </colgroup><tbody>
</tbody>

 

[vcoolio]

Hello Alizera,

In the code above, add the following line:-

ws1.UsedRange.Offset(1).ClearContents

just after this line:-

fSearch = ws1.Range("D1").Value

This will clear the "Summary" sheet before any new transfer of data which means that all the data in the individual sheets will remain.

Next, add the following line:-

ws1.Range("B" & Rows.Count).End(xlUp)(2).FormulaR1C1 = "=SUM(R2C2:R[-1]C2)"

just after this line:-

ws1.Range("A" & lr).PasteSpecial xlPasteValues

The formula will total Column B after each transfer.

Cheerio,
vcoolio.

 

[alireza123456]

Hi
thanks dear
it was interesting but my means was not it.
i want a new sheet that consolidate all sheet and in it i can see total income of each id not it's subsection.
thanks for your camaraderie.

 

[vcoolio]

Hello Alireza,

I have created another code which can be placed beneath the existing one which should do as you ask. Following are the two codes:-

Sub SearchShts()

Application.ScreenUpdating = False

        Dim lr As Long
        Dim lr2 As Long
        Dim fSearch As String
        Dim ws As Worksheet
        Dim cell As Range
        Dim ws1 As Worksheet
Set ws1 = Worksheets("Summary")

fSearch = ws1.Range("D1").Value

For Each ws In Worksheets
        If ws.Name <> "Summary" And ws.Name <> "List" Then
        
For Each cell In ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
  If cell.Value = fSearch Then
     lr = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
       cell.EntireRow.Copy
         ws1.Range("A" & lr).PasteSpecial xlPasteValues
             ws1.Range("C" & lr).Value = ws.Name
               ws1.Columns.AutoFit
                 End If
             Next
       End If
Next ws
 
ws1.Range("A" & Rows.Count).End(3)(2) = "Total:"
TotalAll
ws1.Range("D1") = "SEARCH"
ws1.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Sub TotalAll()

     Dim ws1 As Worksheet
     Dim lr As Long
     Dim cstart As Long

Set ws1 = Worksheets("Summary")
lr = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
cstart = 2

For i = 2 To lr + 1
    If ws1.Range("B" & i).Value = 0 Or ws1.Range("B" & i) = "" Then
        ws1.Range("B" & i).Formula = "=SUM(B" & cstart & ":B" & i - 1 & ")"
    ElseIf Left(ws1.Range("A" & i).Value, 3) = "Tot" Then
        cstart = i + 1
    End If
Next i

End Sub

As you can probably see, the first code (SearchShts) calls the second code (TotallAll).

Now, every time that you select an ID from the drop down in the search box and click on "GO", the code will bring across to the Summary sheet all data relevant to the selected ID and place a total at the bottom of the data set. When you select a new ID, the same will happen and so on (but only on selection of each ID). All IDs and associated data will be consolidated as "blocks" of data in the Summary sheet with their respective total for Column B. Nothing will be cleared from the Summary sheet.

Following is the link to the updated test work book:-

https://www.dropbox.com/s/hh9lhigckfdcc9s/Alireza(3).xlsm?dl=0

Cheerio,
vcoolio.

 

[alireza123456]

Hi dear
Very very thanks.
God bless you.

 

[vcoolio]

Hello Alireza,

You're welcome. I'm glad that I was able to help.

Please mark the thread as solved.

Good luck!

Cheerio,
vcoolio.

 

[alireza123456]

Hi dear vcoolio
Thanks so much.
http://www.mrexcel.com/forum/excel-questions/957973-thread-solved.html#post4601166