Extracting data from multiple sheets and into a new sheet

danjuma

Active Member
Joined
Sep 21, 2008
Messages
251
Hello all.

1. I have a workbook with about 30 worksheets, each for each member of staff. How each worksheet looks like is shown in the first image below. There is one other additional sheet in this case named ‘Summary’ and looks like the second image below.

2. So, what I want is someone opens the ‘Summary’ sheet, input a date in cell B3, and the VBA code would then go through the other 30 worksheets, and extract data corresponding to that date only into the ‘Summary’ sheet. There could be more than one entry for a particular date in the worksheets. Not all the data in each worksheet is required. The data required is:

Day: from worksheet cell D6 to Summary sheet cell B4

Name: from worksheet cell I3 to Summary sheet cell A6 downwards

Emp No: from worksheet cell I2 to Summary sheet cell B6 downwards

Grade Worked: from worksheet cell E6 to Summary sheet cell C6 downwards

HGW?: from worksheet cell F6 to Summary sheet cell D6 downwards

Start Time: from worksheet cell G6 to Summary sheet cell E6 downwards

Finish Time: from worksheet cell H6 to Summary sheet cell F6 downwards

Person Covered: from worksheet cell I6 to Summary sheet cell G6 downwards

Total Hours (in MR): from worksheet cell M6 to Summary sheet cell H6 downwards

Type of Variation: from worksheet cell S6 to Summary sheet cell I6 downwards

Authorised By: from worksheet cell Q6 to Summary sheet cell J6 downwards

3. (If possible, not essential, as could be done manually), once the data has been extracted, for the summary for that date be saved as a separate workbook in a specified directory/location.

Many thanks.

First image
Source.JPG


Second image
destination.JPG
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Please upload Example one of Source sheet & Summary sheet with Xl2BB Addin or upload at Free-Hosting site e.g. GoogleDrive, OneDrive, DropBox and Insert Link here to we can work with data.
 
Upvote 0
Also you can Try this as Worksheet Change Event:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
Dim i As Long, Lr As Long, Sh As Worksheet, ShD As Worksheet, K As Long, f As Long, g As Long, Lrs As Long, M As Long
Application.EnableEvents = False
Set ShD = Sheets("Summary")
With ShD
Lrs = .Range("B" & Rows.Count).End(xlUp).Row
.Range("B4").Value = Application.WorksheetFunction.Text(.Range("B3").Value, "dddd")
i = 6
For Each Sh In Worksheets
f = 6
If Sh.Name <> "Summary" Then
Lr = Sh.Range("B" & Rows.Count).End(xlUp).Row
M = Application.WorksheetFunction.CountIf(Sh.Range("B6:B" & Lr), .Range("B3").Value)
For g = 1 To M
K = Application.WorksheetFunction.Match(.Range("B3"), Sh.Range("B" & f & ":B" & Lr), 0) + f - 1
.Range("A" & i).Value = Sh.Range("I3").Value
.Range("B" & i).Value = Sh.Range("I2").Value
.Range("C" & i & ":G" & i).Value = Sh.Range("E" & K & ":I" & K).Value
.Range("H" & i).Value = Sh.Range("M" & K).Value
.Range("I" & i).Value = Sh.Range("S" & K).Value
.Range("J" & i).Value = Sh.Range("Q" & K).Value
i = i + 1
f = K + 1
Next g
End If
Next Sh
If i < Lrs Then .Range("A" & i & ":J" & Lrs).ClearContents
End With
Application.EnableEvents = True
End Sub
 
Upvote 0
Also you can Try this as Worksheet Change Event:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
Dim i As Long, Lr As Long, Sh As Worksheet, ShD As Worksheet, K As Long, f As Long, g As Long, Lrs As Long, M As Long
Application.EnableEvents = False
Set ShD = Sheets("Summary")
With ShD
Lrs = .Range("B" & Rows.Count).End(xlUp).Row
.Range("B4").Value = Application.WorksheetFunction.Text(.Range("B3").Value, "dddd")
i = 6
For Each Sh In Worksheets
f = 6
If Sh.Name <> "Summary" Then
Lr = Sh.Range("B" & Rows.Count).End(xlUp).Row
M = Application.WorksheetFunction.CountIf(Sh.Range("B6:B" & Lr), .Range("B3").Value)
For g = 1 To M
K = Application.WorksheetFunction.Match(.Range("B3"), Sh.Range("B" & f & ":B" & Lr), 0) + f - 1
.Range("A" & i).Value = Sh.Range("I3").Value
.Range("B" & i).Value = Sh.Range("I2").Value
.Range("C" & i & ":G" & i).Value = Sh.Range("E" & K & ":I" & K).Value
.Range("H" & i).Value = Sh.Range("M" & K).Value
.Range("I" & i).Value = Sh.Range("S" & K).Value
.Range("J" & i).Value = Sh.Range("Q" & K).Value
i = i + 1
f = K + 1
Next g
End If
Next Sh
If i < Lrs Then .Range("A" & i & ":J" & Lrs).ClearContents
End With
Application.EnableEvents = True
End Sub

This is just fantastic! Thank you so much, I am most grateful! Just a couple of things pleases:

(1) My fault, I missed out a column in summary sheet. There should be a column 'Reason' between columns G and I (image attached), and this should have data from worksheet cell K downwards.

(2) When a date is selected in Summary sheet cell B3, could the previous data on sheet be cleared before the new data is extracted into the sheet, as what's happening is that some data get left behind. I.E, say I initially put in a date say 01/09/2021 in B3, data get extracted say up to rows A6 to A12. If I put in a different date, say 03/09/2021, and the data from that goes only up to A10, data in the last two rows from before A11 to A12 still shows, which obviously will be misleading to whoever views it.

Many thanks

destination2.JPG
 
Upvote 0
About:
1. I correct code and add it to code
2. I think this line clear lines after last inputted row of new date:
VBA Code:
If i < Lrs Then .Range("A" & i & ":J" & Lrs).ClearContents

But again I changed that line of code to first clear cells from row 6 to down then add new date data:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
Dim i As Long, Lr As Long, Sh As Worksheet, ShD As Worksheet, K As Long, f As Long, g As Long, Lrs As Long, M As Long
Application.EnableEvents = False
Set ShD = Sheets("Summary")
With ShD
Lrs = .Range("B" & Rows.Count).End(xlUp).Row
.Range("A6:K" & Lrs).ClearContents
.Range("B4").Value = Application.WorksheetFunction.Text(.Range("B3").Value, "dddd")
i = 6
For Each Sh In Worksheets
f = 6
If Sh.Name <> "Summary" Then
Lr = Sh.Range("B" & Rows.Count).End(xlUp).Row
M = Application.WorksheetFunction.CountIf(Sh.Range("B6:B" & Lr), .Range("B3").Value)
For g = 1 To M
K = Application.WorksheetFunction.Match(.Range("B3"), Sh.Range("B" & f & ":B" & Lr), 0) + f - 1
.Range("A" & i).Value = Sh.Range("I3").Value
.Range("B" & i).Value = Sh.Range("I2").Value
.Range("C" & i & ":G" & i).Value = Sh.Range("E" & K & ":I" & K).Value
.Range("H" & i).Value = Sh.Range("K" & K).Value
.Range("I" & i).Value = Sh.Range("M" & K).Value
.Range("J" & i).Value = Sh.Range("S" & K).Value
.Range("K" & i).Value = Sh.Range("Q" & K).Value
i = i + 1
f = K + 1
Next g
End If
Next Sh
End With
Application.EnableEvents = True
End Sub
 
Upvote 0
Solution
About:
1. I correct code and add it to code
2. I think this line clear lines after last inputted row of new date:
VBA Code:
If i < Lrs Then .Range("A" & i & ":J" & Lrs).ClearContents

But again I changed that line of code to first clear cells from row 6 to down then add new date data:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
Dim i As Long, Lr As Long, Sh As Worksheet, ShD As Worksheet, K As Long, f As Long, g As Long, Lrs As Long, M As Long
Application.EnableEvents = False
Set ShD = Sheets("Summary")
With ShD
Lrs = .Range("B" & Rows.Count).End(xlUp).Row
.Range("A6:K" & Lrs).ClearContents
.Range("B4").Value = Application.WorksheetFunction.Text(.Range("B3").Value, "dddd")
i = 6
For Each Sh In Worksheets
f = 6
If Sh.Name <> "Summary" Then
Lr = Sh.Range("B" & Rows.Count).End(xlUp).Row
M = Application.WorksheetFunction.CountIf(Sh.Range("B6:B" & Lr), .Range("B3").Value)
For g = 1 To M
K = Application.WorksheetFunction.Match(.Range("B3"), Sh.Range("B" & f & ":B" & Lr), 0) + f - 1
.Range("A" & i).Value = Sh.Range("I3").Value
.Range("B" & i).Value = Sh.Range("I2").Value
.Range("C" & i & ":G" & i).Value = Sh.Range("E" & K & ":I" & K).Value
.Range("H" & i).Value = Sh.Range("K" & K).Value
.Range("I" & i).Value = Sh.Range("M" & K).Value
.Range("J" & i).Value = Sh.Range("S" & K).Value
.Range("K" & i).Value = Sh.Range("Q" & K).Value
i = i + 1
f = K + 1
Next g
End If
Next Sh
End With
Application.EnableEvents = True
End Sub

I cannot thank you enough! I am so grateful! As you give, so may you receive in 10 folds. Thank you very much!
 
Upvote 0
I cannot thank you enough! I am so grateful! As you give, so may you receive in 10 folds. Thank you very much!

Okay, just noticed one little problem. If you input a date in Summary sheet cell B3 that does not return any data. When you then input a different date in cell B3, the code is clearing the data from row 5 downwards instead of from row 6 downwards. So, looks like if there is already data in row 6, it clears contents from row 6. But if no data in row 6, it clears the contents from row 5, and thus clearing the headers.
 
Upvote 0
Rich (BB code):
If you input a date in Summary sheet cell B3 that does not return any data

Worksheet change event only Triggered if you input date at cells then Press Enter. if you paste date at cell doesn't work.

Clearing from Row 5
I think this is because you don't have data at column B. then Change this line at code:
VBA Code:
.Range("A6:K" & Lrs).ClearContents
TO
VBA Code:
if Lrs > 5 Then .Range("A6:K" & Lrs).ClearContents
 
Upvote 0
Worksheet change event only Triggered if you input date at cells then Press Enter. if you paste date at cell doesn't work.

I am aware of this. When I said no data returned, I meant no data for that date in any of the worksheets.

if Lrs > 5 Then .Range("A6:K" & Lrs).ClearContents

Worked! Perfect! Many thanks!
 
Upvote 0

Forum statistics

Threads
1,213,554
Messages
6,114,280
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top