Is there a way to extract the same range of data from specific worksheets in an excel workbook? - excel

Question

Suppose you have an excel workbook with 30 sheets, and you would like to extract data from the range A1:K40 from every sheet into that workbook, and then add all of the extracted data into a single excel sheet in a different workbook. Would this be possible?
I would like to build it such that the user is prompted to select a file, and the file selected will be of the same format, a workbook with 28-31 sheets, and complete the function as previously stated. An additional feature I'd like to add would be when the user selects the workbook, they will be prompted to select which sheets to extract data from within that workbook.
I'd appreciate if anyone could direct me to similar example or even better, just guide me on which vba functions would be best to make this work.

Answer 1

Please, try the next way. It will create a string composed by concatenation of all sheets name with their index and the user is asked to choose the index of sheets to have ranges copied. They should choose them writing the index separated by comma (2,5,9,12). In case of more consecutive sheets, they can use 2,5,9-12,15, 9-12 meaning sheets form 9 to 12 (9,10,11,12). You should configurate the code using the sheets name where the ranges to be copied **instead "AllSheets" generically used in the code):
Sub CopySomeSheets()
Dim wbC As Workbook, wb As Workbook, ws As Worksheet, wsCopy As Worksheet, lastR As Long
Dim strAllSheets As String, strSelSheets As String, arrSheets, i As Long
Set wbC = ActiveWorkbook 'use here the workbook where from to copy sheets
Set wb = ThisWorkbook 'use here the workbook where to copy all ranges
Set ws = wb.Worksheets("AllSheets") 'the sheet where all ranges should be pasted!!!
'create the list of all sheets from whitch to choose the ones to be copied:
For i = 1 To wbC.Sheets.count
strAllSheets = strAllSheets & wbC.Sheets(i).name & " - " & i & vbCrLf
Next i
strSelSheets = InputBox("Please, select the sheets to be copied." & vbCrLf & _
"Use the sheets number (after its name) separated by comma ("","")." & vbCrLf & _
"More consecutive sheets should be represented as ""5-8"", which means sheets 5,6,7,8." & _
vbCrLf & vbCrLf & strAllSheets, _
"Make sheets selection")
If strSelSheets = "" Then MsgBox "You did not select any sheet...": Exit Sub 'in case of pressing Cancel or Top right X
arrSheets = makeSheetsArray(Split(Replace(strSelSheets, " ", ""), ","), wbC) 'make an array of sheets indexes
'copy the ranges from above selected sheets:
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual 'a little optimization
For i = 0 To UBound(arrSheets)
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row 'lastr row on A:A
If lastR > 1 Then lastR = lastR + 1 'first range is copying starting from A1, the rest in the next empty row
wbC.Worksheets(CLng(arrSheets(i))).Range("A1:K40").Copy ws.Range("A" & lastR) 'copy the range
Next i
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Ready..."
End Sub
Function makeSheetsArray(arr, wb As Workbook) As Variant 'it makes an array of all selected sheets (split x-y cases)
Dim arrFin, arr_, k As Long, i As Long, j As Long
ReDim arrFin(wb.Sheets.count) 'maximum possible number of sheets
For i = 0 To UBound(arr)
If InStr(arr(i), "-") > 0 Then 'for the case of x-y:
arr_ = Application.Evaluate("ROW(" & Replace(arr(i), "-", ":") & ")") ' 2D array base 1
For j = 1 To UBound(arr_)
arrFin(k) = arr_(j, 1): k = k + 1
Next j
Else
arrFin(k) = arr(i): k = k + 1
End If
Next i
ReDim Preserve arrFin(k - 1)
makeSheetsArray = arrFin
End Function
Please, send some feedback after testing it.
If something not clear enough, do not hesitate to ask for clarifications...