Help finding and copying into an array

Hi All,

This has got me beat! I can't figure out if it's an activation issue or not but I'm banging my head against a wall. I've got other areas to copy inot an array and pulled successfully however I cant seem to get this one working. Could anybody point out what I may be missing? I think I've gone 'code blind!'

I'm trying to do the following:

1. Search for a title in a cell
2. If found, copy everything under said title into an array via calling a sub
3.If not found msg up and move on.
4. Copy the array into the same worksheet (As a test to see if its captured)

Sub Openworkbookandcopy()
Dim vFile As Variant
Dim Sourcewb As Workbook
Dim Sourcews As Worksheet
Dim Estate_Overview As Worksheet
Dim Audit_Record As Worksheet
Dim Evidence_And_Council_Band As Worksheet
Dim House_Types As Worksheet
Dim CWS As Worksheet
Dim TmpWS As Worksheet
Dim WS As Worksheet

Dim unhideallsheets


Dim EstateName As Variant
Dim Developer As Variant
Dim LocalityID As Variant
Dim AuditDate As Variant
Dim Description As Variant
Dim Housetype As Variant
Dim SelRange As Variant
Dim CTBand As Variant
Dim a(), ColNum As Long, v
Dim Builder As Variant
Dim CellTxt As String




For Each WS In ActiveWorkbook.Worksheets

        If WS.Name <> "Sheet1" And WS.Name <> "Sheet2" And WS.Name <> "Sheet3" Then

            With WS
                CellTxt = .Range("A2")

                If InStr(1, CellTxt, "DWELLING TYPE OR NAME") Then
                    Call CaptureSheetData
                    MsgBox "Yep! " & .Name
                    Else: MsgBox "Not Found! " & .Name
                                    
                End If

            End With

        End If

    Next WS



 'Activate Thisworkbook and sheet'
 'workbooks("TestyMcTesty 2").Activate
 'Worksheets("Sheet8").Activate
 
 'Paste collected array as a test'
 
 Range("C:C").Value = Housetype

 
 
 
End Sub
 
Sub CaptureSheetData()

'Below Captures the Housetype'

'Working with activesheet'
With ActiveSheet
    On Error Resume Next
    
    'Find the column number where the column header is'
      ColNum = Application.WorksheetFunction.Match("DWELLING TYPE OR NAME", .Rows(1), 0)
       
         
    'Get array value from Range(TopLeftCell, BottomRightCell)'
    Housetype = Range(.Cells(2, ColNum), .Cells(.Rows.Count, ColNum).End(xlUp)).Value
    

    End With
  
End Sub

Any help would be MASSIVELY appreciated.

Hi AlphaFrog,

That's great tanks, solves one of my issues

Appreciate you taking the time to read my code!

Well I've added a little extra (using your advice on public Dims) and it's doing what I tell it too...kinda

In the following section:

'Below searches for the first address sheet looking for GROUP CODE. It continues to loop until not found.'
  
   For Each ws In ActiveWorkbook.Worksheets

   If ws.Name <> "ESTATE FILE SUMMARY" And ws.Name <> "EVIDENCE AND COUNCIL BAND" And ws.Name <> "AUDIT RECORD" Then

   With ws
   celltxt = .Range("D2")
   x = InStr(1, celltxt, "GROUP CODE")
   y = IIf(x > 0, "Yep", "Nope")
       If InStr(1, celltxt, "GROUP CODE") Then
       ws.Activate
       Call CaptureSheetData(Sourcewb, ws, Housenumber)   'This is the Sub at the bottom which SHOULD be called....but its being a *****'
       MsgBox "Yep! " & .Name
   End If

   End With
   MsgBox y
   End If

   Next ws

It searches through a workbook I defined earlier fine and it does indeed find the headers I required in 3 separate sheets. However when it executes the 'CallCapturesheetdata' sub, it only copies the column for the last sheet found.

The capture sheet data code is below:

Sub CaptureSheetData(Sourcewb As Workbook, ws As Worksheet, Housenumber As Variant)
             
    Dim a(), colnum As Long, v
    Dim unhideallsheets
    Dim x As String
    Dim y As String
    
    x = Sourcewb.Name
    y = ws.Name
       
   
With ActiveSheet
    On Error Resume Next
    
    'Find the column number where the column header is'
       colnum = Application.WorksheetFunction.Match("House Number", .Rows(2), 0) 'Changed rows 1 to 2 as address sheets are different'
       
         
    'Get array value from Range(TopLeftCell, BottomRightCell)'
    Housenumber = Range(.Cells(3, colnum), .Cells(.Rows.Count, colnum).End(xlUp)).Value ' Change 2 to 3 as adddress sheets are different'
  End With
  
    End Sub

There's additional bits for test purposes so it may look a mess.

I'm trying to capture the data from each of the 3 columns on each of the 3 sheets it found the word 'Housenumber' but as stated before it only captures the column on the last found sheet. I may have to try and put them each into a separate array which wouldn't be an issue....it's just getting to that point!

Thanks for your help!

Hi AlphaFrog,

Thanks again for your help. The concept of copy/paste wouldn't work for me as it needs to be arrays for calling into a different workbook later on.

However form what you're saying in regards to the overwriting (Due to "C:C") could be the issue!. Ill have a tinker with what you have put i.e. rather than copy/paste ill create an array and see if that solves the problem.

Thanks again!

I can't seem to get it working :/.

Is there a way to keep what were capturing (From the 3 sheets) and then paste the array to a single column...not overwriting the previous sheet?

The reason I have to search is because my 4th sheet onwards are always going to be named differently and this code has to be used hundreds of times over to copy old data from various sheets onto a new template.

Thanks

Hey Alpha,

I've always just placed into arrays ha...not sure why just the way I was taught!

The code still seems to be only copying the last sheets column in which it found the word house number. When pasting (Using your method) it still only copies the final sheet and not the other two columns in sheets 6 and 7 under the word house number...this ones a tough one!

I did have an issue with #N/A being copied over in other sections of my work but your way of pasting the array on next count removes that so thank you You accidently helped another area haha

I forgot to add the sub code that captures the column:

Sub CaptureSheetData(Sourcewb As Workbook, ws As Worksheet, Housenumber As Variant)
             
    Dim a(), colnum As Long, v
    Dim unhideallsheets
    Dim x As String
    Dim y As String
    
    x = Sourcewb.Name
    y = ws.Name
       
    'If IsEmpty(ActiveCell.Value) Then
     'Groupcode = Range("D3:D50").Value
'End If

'Working with activesheet'
With ActiveSheet
    On Error Resume Next
    
    'Find the column number where the column header is'
       colnum = Application.WorksheetFunction.Match("House Number", .Rows(2), 0) 'Changed rows 1 to 2 as address sheets are different'
       
         
    'Get array value from Range(TopLeftCell, BottomRightCell)'
    Housenumber = Range(.Cells(3, colnum), .Cells(.Rows.Count, colnum).End(xlUp)).Value ' Change 2 to 3 as adddress sheets are different'
  End With
  
    End Sub

My thought is that the code is Cycling through the sheets THEN capturing hence why it's allways the final sheet stating YES that captures and not the other YES sheets. Perhaps It needs to

1.Find a sheet with the criteria
2.Activate the capture
3.Search again form that sheet for another YES
4. If Yes then Capture (And repeat)
5. If no then stop.

Hi Alpha,

I do get a YES for all 3 sheets stating the search criteria is on them all however it only copies the final sheet with a yes. As Far as I'm aware I didn't change anything however I can re-add the code below.

Below is meant to Grab the columns under the search criteria, no matter how many sheets there are i.e. if there are 3 sheets with a house number column then it should capture all 3 columns. In addition there may be more or less with the header...i.e. if 7 sheets contain the header then I want all 7 columns from the 7 sheets pasted into the 1 array

For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "ESTATE FILE SUMMARY" And ws.Name <> "EVIDENCE AND COUNCIL BAND" And ws.Name <> "AUDIT RECORD" Then
            If InStr(1, ws.Range("D2").Text, "GROUP CODE", 1) > 0 Then
                ColNo = Application.Match("House Number", ws.Rows(2), 0)    'Use Application.Match to prevent code stopping on error when no match
                If Not IsError(ColNo) Then
                    MsgBox ws.Name & vbLf & "Column Number: " & ColNo, , "Yep!"
                    'Copy to an array
                    Housenumber = ws.Range(ws.Cells(3, ColNo), ws.Cells(Rows.Count, ColNo).End(xlUp)).Value
                    
                Else
                    MsgBox ws.Name & vbLf & "No ''House Number'' column. ", , "Nope!"
                End If
            Else
                MsgBox ws.Name & vbLf & "No ''GROUP CODE'' " & ws.Name, , "Nope!"
            End If
        End If
    Next ws

'Once the new template is opened and sheet is selected, this is then meant to paste ALL OFF THE COLUMNS into 1 column under C HOWEVER it only seems to paste the final sheet/column when it searches.

This issue is either only the final column is being captured into the array, or when pasting, something is pasting correctly? I'm assuming it's because only the final search results is being captured.

Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Housenumber, 1)).Value = Housenumber

I can't add the files due to there being 3 Excel files involved, one of which is sensitive but hopefully the code is enough?

Does this make more sense ha?

If it can't be done then so be it. I may have to look into a way of searching for the header then placing each column under SEPERATE arrays?

Thanks again.

Apologies, Just understood what the code did...it was the paste into the new template which is static

Scratch my last comment!

Thank you, I shall give it a go and see if it works.

My concern is the reference to "Sheet 8". I will never know the sheet name when running the code in future i.e. after the first 3 dedicated sheets the following sheet names will ALWAYS be different every time this code is ran by a user hence why I needed the search for header function.
Will that make a difference?

You sir....are my new hero.

Thank you so much for your time!

I'd rep you more if I could

It all works however a issue has cropped up annoyingly :/.

Lets say I have the following Data:

Plot Number: House Number:

Sheet 1: Sheet 1:
1 1
2 2
3 3
4 4
5 5
6

Sheet 2:

1 1
2 2
3 3
4 4
5 5
6 6

Because of the xlup method it pastes as:

1 1
2 2
3 3
4 4
5 5
6 1
1 2
2 3
3 4
4 5
5 6
6

Meaning they no longer marry up come Sheet 2+

It should be

1 1
2 2
3 3
4 4
5 5
6
1 1
2 2
3 3
4 4
5 5
6 6

Is there a way in that code

'Copy to an array
                    HouseNumber = ws.Range(ws.Cells(3, ColNo), ws.Cells(Rows.Count, ColNo).End(xlUp)).Value
                    'Paste array to the next empty rows in column C
                    Workbooks("Estate File Template V1.xls").Activate
                    Worksheets("Properties").Activate
                    NewTemplatewb.Sheets("Properties").Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(HouseNumber, 1)).Value = HouseNumber

To make it NOT overwrite spaces?

I know I've asked a lot ha but you seem to know what you're doing!

Another example is the following:

example 2a.jpg

example 2b.jpg

Blank columns seem to paste through with unusual headers too...

I've put a row offset in of 3 to split the sheets as seen in the code below:

If ws.Name <> "ESTATE FILE SUMMARY" And ws.Name <> "EVIDENCE AND COUNCIL BAND" And ws.Name <> "AUDIT RECORD" Then
        
                If InStr(1, ws.Range("A2").Text, "Plot Number", 1) > 0 Then
                ColNo = Application.Match("Plot Number", ws.Rows(2), 0)    'Use Application.Match to prevent code stopping on error when no match
                If Not IsError(ColNo) Then
                    'MsgBox ws.Name & vbLf & "Column Number: " & ColNo, , "Yep!"
                    'Copy to an array
                    PlotNumber = ws.Range(ws.Cells(3, ColNo), ws.Cells(Rows.Count, ColNo).End(xlUp)).Value
                    'Paste array to the next empty rows in column B
                    Workbooks("Estate File Template V1.xls").Activate
                    Worksheets("Properties").Activate
                    NewTemplatewb.Sheets("Properties").Range("B" & Rows.Count).End(xlUp).Offset(3).Resize(UBound(PlotNumber, 1)).Value = PlotNumber
                Else
                    'MsgBox ws.Name & vbLf & "No ''Plot Number'' column. ", , "Nope!"
                End If
                End If
                End If

But I cnt see that being the issue!

Okay, Thanks for all your help anyway.