PDA

View Full Version : Getting data from different sheet and sort and sum



MPDK166
04-12-2011, 04:08 AM
Hi,

I want to get data from different sheets and set it in de main sheet. Also I need to sort it this data and sum it. Attached is a sample of what I want, however, the code is missing. The sheet (Main Sheet) is the master sheet and the data needs to be set overthere and that particular way. Currently I have done it manually, but I want this automically. Who can help me?

Grtz,

MPDK166

mancubus
04-12-2011, 02:29 PM
i would use subtotal for employee hours...

try with a copy of your file


Sub cons_ws()
'http://www.vbaexpress.com/forum/showthread.php?t=36972

Dim ws As Worksheet, wsMain As Worksheet
Dim LR As Long, wsM_LR As Long

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wsMain = Worksheets("Main Sheet")

For Each ws In Worksheets
wsM_LR = wsMain.Cells.Find("*", , , , xlByRows, xlPrevious).Row
If UCase(ws.Name) <> UCase(wsMain.Name) Then
With ws
LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
.Range("A2:A" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "B")
.Range("B2:B" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "A")
.Range("C2:C" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "C")
.Range("D2:D" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "E")
.Range("E2:E" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "D")
End With
End If
Next ws

With wsMain
.Range("A2:E" & wsM_LR).Sort Key1:=.Range("A1")
.Range("B" & Range("A65536").End(xlUp).Row + 1 & ":B" & Range("B65536").End(xlUp).Row).ClearContents
.Range("A2").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3)
End With

Set wsMain = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub

MPDK166
04-14-2011, 06:16 AM
This is very nice start, however, some small improvements I need to make.

While updating this sheet, data will be copied twice in the sheet. Therefore I used this code:
Worksheets("Main Sheet").Range("A2:E65536").Delete Shift:=xlShiftUp

Unfortunately the grouping (in the side, the collapse option of the lines) keeps growing, unless using this code. How to delete this grouping also?

The sorting of the names (Column A) is not working.

Any ideas?

mancubus
04-14-2011, 02:24 PM
i assumed main sheet a blank sheet with only column heads.

u may use

wsMain.Range("A2:E" & Range("A65536").End(xlUp).Row).Clear

to clear all or

wsMain.Range("A2:E" & Range("A65536").End(xlUp).Row).ClearContents

to clear cell contents.





.Range("A2:E" & wsM_LR).Sort Key1:=.Range("A1")

this line is working for me. tested the code in xl2007 before positng. and it worked for me. (xl2003 vba sort method)

if not works, you can record a macro.
turn on the macro recorder, do sorting, stop recording, copy the related lines and paste in this procedure.





Unfortunately the grouping (in the side, the collapse option of the lines) keeps growing, unless using this code. How to delete this grouping also?
i'm not understanding this part. if u want to remove subtotal, add this line to an appropriate place in the code:

wsMain.Range("A2").RemoveSubtotal

MPDK166
04-15-2011, 06:12 AM
I have implemented the code in my main file, however, there is a new challenge.

This is the code I have got this far:
Sub cons_ws()

Dim ws As Worksheet, wsMain As Worksheet
Dim LR As Long, wsM_LR As Long

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wsMain = Worksheets("Uren per medewerker")
Set ws = Worksheets("Opleidingen")

If Cells(2, 1) <> "" Then wsMain.Range("A2:E65536").EntireRow.Delete

'For Each ws In Worksheets
wsM_LR = wsMain.Cells.Find("*", , , , xlByRows, xlPrevious).Row
' If UCase(ws.Name) <> UCase(wsMain.Name) Then
With ws
LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
.Range("C7:C" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "A")
.Range("B7:B" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "B")
.Range("E7:E" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "C")
.Range("G7:G" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "D")
.Range("F7:F" & LR).Copy Destination:=wsMain.Cells(wsM_LR + 1, "E")
End With
' End If
' Next ws

With wsMain
.Range("A2:E65536").Select
.Range("A2:E65536").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
.Range("A2").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3)
End With

Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If .Value = "" Then .EntireRow.Delete
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With

Set wsMain = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub


I my file I have like 15 worksheets (with all kind of different names) and I want to get the data from like 10 sheets. How can I do this with a loop instead of doing right now?
Now I have set the variable ws manually and if I want to apply this code to multiple sheets, I must use the same code multiple times.

Any ideas?

halimi1306
04-15-2011, 11:01 PM
I saw your sample, why don't you have same header for master and sheets, that will make it easier.

Try this code:
Sub AllDataToFirstSheet()
Dim SheetCtr As Double
Dim Last1Row As Double
Dim LastShtRow As Double
For SheetCtr = 2 To ActiveWorkbook.Sheets.Count
LastShtRow = Worksheets(SheetCtr).Cells(Rows.Count, "A").End(xlUp).Row
If Worksheets(SheetCtr).Cells(Rows.Count, "E").End(xlUp).Row > LastShtRow Then
LastShtRow = Worksheets(SheetCtr).Cells(Rows.Count, "A").End(xlUp).Row
End If

Last1Row = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
If Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row > Last1Row Then
Last1Row = Worksheets(1).Cells(Rows.Count, "E").End(xlUp).Row
End If

Worksheets(SheetCtr).Range("A2:E" & LastShtRow).Copy _
Destination:=Worksheets(1).Range("A" & Last1Row + 1)

Next SheetCtr
End Sub