To extract certain location cell values from mutiple worksheets in Excel along with worksheet name - excel

Question

I have encountered a problem during my work.
There are over one hundred worksheets in my excel, and I would like to extract values from certain location (I25:K25, I50:K50, I95:K95) along with the worksheet name on the beside for every worksheet.
I would like to have these extracted values pasted on a new worksheet.
Does anyone know if there is any excel formula or excel macro I could use to achieve the goal?

Answer 1

I'm not proficient with formulas, but it would certainly be doable with VBA.
Look into For Each..Next loops, which I think you should use to go through all sheets.
Next, the .Name property will extract the sheet's name for you. You can save this to a variable and fill a cell with.
Getting values from one cell to another is as easy as
.Sheets(1).Range("A1:B1").Value = .Sheets(2).Range("A1:B1").Value
Note that SO is not a free code writing service, so I won't go as far as writing the entire procedure for you. If you have some code but encounter problems, come back to us.
Useful links:
looping through sheets
Copying cell values
Workbook and -sheet objects

Answer 2

This code loop all sheets except sheet called Results, code sheet name in column A and range values in columns B:D.
Option Explicit
Sub test()
Dim ws As Worksheet, wsResults As Worksheet
Dim Lastrow As Long
With ThisWorkbook
Set wsResults = .Worksheets("Results")
For Each ws In .Worksheets
If ws.Name <> "Results" Then
Lastrow = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
wsResults.Range("A" & Lastrow + 1 & ":A" & Lastrow + 3).Value = ws.Name
ws.Range("I25:K25").Copy wsResults.Range("B" & Lastrow + 1)
ws.Range("I50:K50").Copy wsResults.Range("B" & Lastrow + 2)
ws.Range("I95:K95").Copy wsResults.Range("B" & Lastrow + 3)
End If
Next ws
End With
End Sub

Answer 3

Ranges to New Master Worksheet
Workbook
Download
(Dropbox)
Adjust the values in the constants (Const) section to fit your
needs.
The code will only affect the workbook containing it.
The code will delete a possible existing worksheet named after
cTarget, but will only read from all other worksheets. Then it will
create a worksheet named after cTarget and write the read data to it.
To run the code, go to the Developer tab and click Macros and
click RangesToNewMasterWorksheet.
Sub RangesToNewMasterWorksheet()
' List of Source Row Range Addresses
Const cRowRanges As String = "I25:K25, I50:K50, I95:K95"
Const cTarget As String = "Result" ' Target Worksheet Name
Const cHead1 As String = "ID" ' 1st Column Header
Const cHead2 As String = "Name" ' 2nd Column Header
Const cHead As Long = 2 ' Number of First Header Columns
Const cRange As String = "Rng" ' Range (Area) String
Const cColumn As String = "C" ' Column String
Const cFirstCell As String = "A1" ' Target First Cell Range Address
Dim wb As Workbook ' Source/Target Workbook
Dim ws As Worksheet ' Current Source/Target Worksheet
Dim rng As Range ' Current Source/Target Range
Dim vntT As Variant ' Target Array
Dim vntA As Variant ' Areas Array
Dim vntR As Variant ' Range Array
Dim NoA As Long ' Number of Areas
Dim NocA As Long ' Number of Area Columns (in Target Array)
Dim i As Long ' Area Counter
Dim j As Long ' Area Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Long ' Target Array Column Counter
' Speed Up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a reference to ThisWorkbook i.e. the workbook containing this code.
Set wb = ThisWorkbook
' Task: Delete a possibly existing instance of Target Worksheet.
Application.DisplayAlerts = False
On Error Resume Next
wb.Worksheets(cTarget).Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Handle unexpected error.
On Error GoTo UnExpected
' Task: Calculate size of Target Array.
' Create a reference to the 1st worksheet. (Note: Not sheet.)
For Each ws In wb.Worksheets
Exit For
Next
' Create a reference to the Source Row Range (in 1st worksheet.
Set rng = ws.Range(cRowRanges)
With rng
NoA = .Areas.Count
ReDim vntA(1 To NoA)
' Calculate Number of Area Columns (NocA).
For i = 1 To NoA
With .Areas(i)
' Write number of columns of current Area (i) to Areas Array.
vntA(i) = .Columns.Count
NocA = NocA + vntA(i)
End With
Next
End With
' Resize Target Array.
' Rows: Number of worksheets + 1 for headers.
' Columns: Number of First Header Columns + Number of Area Columns.
ReDim vntT(1 To wb.Worksheets.Count + 1, 1 To cHead + NocA)
' Task: Write 'Head' (headers) to Target Array.
vntT(1, 1) = cHead1
vntT(1, 2) = cHead2
k = cHead
For i = 1 To NoA
For j = 1 To vntA(i)
k = k + 1
vntT(1, k) = cRange & i & cColumn & j
Next
Next
' Task Write 'Body' (all except headers) to Target Array.
k = 1
For Each ws In wb.Worksheets
k = k + 1
vntT(k, 1) = k - 1
vntT(k, 2) = ws.Name
Set rng = ws.Range(cRowRanges)
m = cHead
For i = 1 To NoA
vntR = rng.Areas(i)
For j = 1 To vntA(i)
m = m + 1
vntT(k, m) = vntR(1, j)
Next
Next
Next
' Task: Copy Target Array to Target Worksheet.
' Add new worksheet to first tab (1).
Set ws = wb.Sheets.Add(Before:=wb.Sheets(1))
ws.Name = cTarget
' Calculate Target Range i.e. resize First Cell Range by size of
' Target Array.
Set rng = ws.Range(cFirstCell).Resize(UBound(vntT), UBound(vntT, 2))
rng = vntT
' Task: Apply Formatting.
' Apply formatting to Target Range.
With rng
.Columns.AutoFit
' Apply formatting to Head (first row).
With .Resize(1)
.Interior.ColorIndex = 49
With .Font
.ColorIndex = 2
.Bold = True
End With
.BorderAround xlContinuous, xlThin
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
' Apply formatting to Body (all except the first row).
With .Resize(rng.Rows.Count - 1).Offset(1)
.Interior.ColorIndex = xlColorIndexNone
With .Font
.ColorIndex = xlColorIndexAutomatic
.Bold = False
End With
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
End With
MsgBox "The program finished successfully.", vbInformation, "Success"
ProcedureExit:
' Speed Down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
UnExpected:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub