Loop through worksheet list to copy and paste data into a summary sheet

[benajamingeldart]

Hi folks, I need some help.

I have 2 workbooks, WB1 contains loads of data and WB2 contains a list of all the worksheets in WB1 against which I want to copy and paste part of the data from WB1 into a WB2 summary table.
I have a macro called 'Pulldata' which will search for a cell value and copy a range of data but have no way of automating this back into WB2 against the correct worksheet name then moving onto the next value in the WB1 list.
Any way of doing this with VBA looping or a vba vlookup worksheet name or something.

Thanks.

Ben

 

[mumps]

Can you post your "Pulldata"?

 

[benajamingeldart]

Sub PullData()
Application.ScreenUpdating = False

Dim WS As Worksheet
Dim rng As Range
Dim LastCol As Long
Dim LastColumn As String
Dim tablerows As Integer
Dim FindString As String
Dim rng2 As Range
Dim lColumn As Long
Dim Merge As Integer
Dim Colarray As Integer
Dim Myarray As Variant

Set WS = ActiveSheet

FindString = "Strain Test Results"
If Trim(FindString) <> "" Then
With WS.Range("A:ZZ")
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
ActiveCell.Offset(0, 1).Select

tablerows = rng.MergeArea.Rows.Count - 1
lColumn = WS.UsedRange.Columns.Count - 1
Colarray = lColumn - (rng.Column)


Set Myarray = Range(ActiveCell, ActiveCell.Offset(tablerows, Colarray))
Myarray.Copy

Else
End If
'End If

End With
End If
End Sub

When each sheet is activated the macro Finds "Strain Test Results" then creates an array to copy back to the original file.

 

[benajamingeldart]

If it helps the following 3 macros are working a loop but then copying only the first sheets data and basically duplicating it for all the sheet name values in the list which will become my summary page. It's pretty messy but the source data is unstructured hence the need to search for a string value then create a bespoke array to copy rather than just referencing ranges.

Sub SearchMasterList()
Dim rngCell As Range
Dim strSheetActive As String: strSheetActive = ActiveSheet.Name
Application.ScreenUpdating = False

With ThisWorkbook.Worksheets("BC Sediment Summary")
For Each rngCell In .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).row)
If Trim(rngCell.value) <> vbNullString Then
Application.Goto rngCell, True

Call Loopsheetsextract(rngCell.value)

Workbooks("GeoData Conversion Tool Flexi-Tool.xlsm").Worksheets("BC Sediment Summary").Activate
ActiveCell.Offset(0, 4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
End If
Application.CutCopyMode = False

Next rngCell


End With

Application.Goto ThisWorkbook.Worksheets(strSheetActive).Cells(1)
Application.ScreenUpdating = True
Set rngCell = Nothing

End Sub

----------------------------------------------------------------------------------------------------------------------------------------------------------

Private Sub Loopsheetsextract(strSheetName As String)
Application.ScreenUpdating = False
Workbooks("Box Core Nodule_Worksheets UK-AB02-BC-XX_revB-1 (Trial).xlsx").Activate
With Worksheets(strSheetName)
Call PullData

End With
End Sub
----------------------------------------------------------------------------------------------------------------------------------------------------------
Sub PullData()
Application.ScreenUpdating = False

Dim WS As Worksheet
Dim rng As Range
Dim LastCol As Long
Dim LastColumn As String
Dim tablerows As Integer
Dim FindString As String
Dim rng2 As Range
Dim lColumn As Long
Dim Merge As Integer
Dim Colarray As Integer
Dim Myarray As Variant

Set WS = ActiveSheet

FindString = "Strain Test Results"
If Trim(FindString) <> "" Then
With WS.Range("A:ZZ")
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
ActiveCell.Offset(0, 1).Select

tablerows = rng.MergeArea.Rows.Count - 1
lColumn = WS.UsedRange.Columns.Count - 1
Colarray = lColumn - (rng.Column)


Set Myarray = Range(ActiveCell, ActiveCell.Offset(tablerows, Colarray))
Myarray.Copy

Else
End If
'End If

End With
End If
End Sub

Thanks for any help.

Ben

 

[mumps]

I'm not sure if you actually need three macros. By looking at your code, it looks like you are working with merged cells which most often cause problems for macros. It looks like you want to find the string "Strain Test Results" anywhere in columns A to ZZ. Once found, you want to copy a range based on the cell to the right of "Strain Test Results". Is this correct? To make it easier to visualize how your data is organized, could you use the XL2BB add-in (icon in the menu) to attach screenshots (not a picture) of the sheet in WB2 containing the sheets names and the summary table and one of the sheets in WB1 that shows the range you want to copy (perhaps highlighted in yellow). Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary). Also, where exactly in the Summary sheet do you want to paste the copied data?

 

[benajamingeldart]

Below is the summary page i'm after in "BC Sediment Summary". Column A list the sheet names to extract the data from. Columns E-O are the results i need to pull from the second workbook (snapshots below) where i search for Strain Test Results ( A merged cell) then activecell offset, selction to pull the relevent data array back into the related location in "BC Sediment Summary". The array unfortunately changes size based on the sample size per test.

The data source is then to be extracted from the master workbook and from each individual worksheet.

As mentioned the master data is all over the place. These worksheets are a mess but historical data that need to be pulled togther.
Below is another example where the strain test results can be found. As mentioned before the results could be placed anywhere in a worksheet so i can't reference specific cells as they will immediately be invalid in another sheet and could be 2 tests or 3 test or more.

Thanks for your interest and help.

 

[mumps]

OK. I think that I can see what you want to do. However, it's hard to work with a picture. In order to test a possible solution, I would have to manually type in all the data into a workbook which would take quite a while and is prone to error. If you use the XL2BB add-in to attach screen shots, I would be able to copy/paste your data. Unfortunately, I can't do that with a picture. Alternately, you could upload a copy of your two files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[benajamingeldart]

XL Loop

Shared with Dropbox

www.dropbox.com

Hopefully this works.
I've pulled any sensitive info and replicated the data from the first 3 sheets into the remaining sheets.

The code needs to be flexible enough to adapt if a new sheet and sheet name is included in both files so please no reference to the exact sheet names or cell references.

 

[mumps]

This macro assumes that "Strain Test Results" is always in column N and that the copied range will always be 4 rows. If this is not the case, the macro will have to be modified. Please let me know with clarifications. The macro now works with the two files you posted.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWB As Workbook, desWS As Worksheet, ws As Range, fnd As Range, cnt As Long, lCol As Long
    Set srcWB = Workbooks("Source Data.xlsx")
    Set desWS = ThisWorkbook.Sheets("BC Sediment Summary")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each ws In desWS.Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants)
        With srcWB.Sheets(ws.Value)
            Set fnd = .Range("N:N").Find("Strain Test Results", LookIn:=xlValues, lookat:=xlWhole)
            cnt = fnd.MergeArea.Rows.Count
            lCol = .Cells(fnd.Row, Columns.Count).End(xlToLeft).Column
            .Cells(fnd.Row, fnd.Column + 1).Resize(cnt, lCol - fnd.Column).Copy desWS.Cells(ws.Row, 5)
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[benajamingeldart]

Thanks very much. This works really nicely and the code is so much more concise. I have changed the .Range"N:N" to .Range"A:ZZ to cater to a larger part of the worksheet. Also, the merged cell part works if the merged cell is a different size. I tested it with a merged cell of 3 instead of 4 and it adapts to still pull across the correct data as anticipated. Thank you so much once again.