[vba] Grab Numerous Columns & Compile Into One

[DataBlake]

I'm at a loss for how to solve this one.
I need to grab part numbers from column A on specific named sheets within the workbook. Lets say they are sheets named "1" "2" and "3".
When i run the macro i need it to grab everything in column A from these sheets and put them compiled into the A column of sheet "4"

any help would be greatly appreciated.

 

[jmacleary]

Hi there. No need for a macro if you could use a formula in sheet 4 to pull them together, so cell A2 on sheet named 4 would be something like: =CONCATENATE('1'!A2," ",'2'!A2," ",'3'!A2)

then just drag down. I assumed you would want spaces between each value, but if not just remove the " " entries.

 

[DataBlake]

Hi there. No need for a macro if you could use a formula in sheet 4 to pull them together, so cell A2 on sheet named 4 would be something like: =CONCATENATE('1'!A2," ",'2'!A2," ",'3'!A2)

then just drag down. I assumed you would want spaces between each value, but if not just remove the " " entries.

two things:
1. I need these part numbers all on separate rows, not together

2. I'm more so looking for a compiler as i do not know how many part numbers all 3 sheets contains (we're talking 1000000+ part numbers)
something that uses Rows.Count in VBA to grab the exact amount of part numbers from all 3 sheets.
I can't figure it out but i can't have blank cells or cells with code that will mess with the 2nd part of my VBA. has to be exact.

so the code would have this thought process.

Sheet 1
lastRow = Range("A" & Rows.Count).End(xlUp).Row
copy A2:A & lastRow
Paste sheet 4 A2
Sheet 2 select
lastRow = Range("A" & Rows.Count).End(xlUp).Row
copy A2:A & lastRow
Paste sheet 4 at the end of the lastrow
sheet 3 select
lastRow = Range("A" & Rows.Count).End(xlUp).Row
copy A2:A & lastRow
Paste sheet 4 at the end of the lastrow

 

[jmacleary]

OK sorry I misunderstood. This should do it for you - replace Sheet1 etc with your choice of sheet names. To do more than 3 sheets, just add them into the array declaration.

Sub GetColumnA()
'

'
Dim SheetNames As Variant
SheetNames = Array("Sheet1", "Sheet2", "Sheet3")
For Each sheetname In SheetNames

lastrow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(sheetname).Range("A2:A" & lastrow).Copy
destrow = Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet4").Select
    Range("A" & destrow).Select
    ActiveSheet.Paste
Next sheetname
End Sub

 

[jmacleary]

NB If there are any blank rows in sheets 1 to 3 above the last used row, they will be copied across. If that may be the case, then put a sort at the end to shift all the blanks to the end.

 

[DataBlake]

OK sorry I misunderstood. This should do it for you - replace Sheet1 etc with your choice of sheet names. To do more than 3 sheets, just add them into the array declaration.

Sub GetColumnA()
'

'
Dim SheetNames As Variant
SheetNames = Array("Sheet1", "Sheet2", "Sheet3")
For Each sheetname In SheetNames

lastrow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(sheetname).Range("A2:A" & lastrow).Copy
destrow = Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet4").Select
    Range("A" & destrow).Select
    ActiveSheet.Paste
Next sheetname
End Sub

You are a saint

 

[DataBlake]

NB If there are any blank rows in sheets 1 to 3 above the last used row, they will be copied across. If that may be the case, then put a sort at the end to shift all the blanks to the end.

I also love that if one of the sheets is blank it does not end in an error code or stop the process

 

[jmacleary]

You are very welcome. Glad to help.

 

[DataBlake]

I have changed my process for how the sheets are generated so there may not be all of the sheet generated by the array.
so right now i have this:

Sub GetColumnA()
'

'
Dim lastRow As Long
Dim SheetNames As Variant
SheetNames = Array("MTH", "WP", "MKK", "TTW", "W1", "RHH")
For Each sheetname In SheetNames

lastRow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(sheetname).Range("A2:A" & lastRow).Copy
destrow = Sheets("Unknown").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Unknown").Select
    Range("A" & destrow).Select
    ActiveSheet.Paste
Next sheetname
    
End Sub

and so if my sheet generator does not generate "MTH" sheet it gets stuck on

lastRow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row

because the code is trying to specify a range that does not exist because the sheet does not exist. how would i get past this if something in the array does not exist?

 

[jmacleary]

OK, so what we need is a test to see if it exists before the copy. I got this code from another thread on here:

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    
    Dim Sht As Worksheet
        
    WorksheetExists = False
        
    For Each Sht In ActiveWorkbook.Worksheets
        If Sht.Name = WorksheetName Then WorksheetExists = True
    Next Sht
    
End Function

Add this after your subroutine and amend the subroutine like this:

Sub GetColumnA()
'

'
Dim lastRow As Long
Dim SheetNames As Variant
SheetNames = Array("MTH", "WP", "MKK", "TTW", "W1", "RHH")
For Each sheetname In SheetNames

If WorksheetExists Then
lastRow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(sheetname).Range("A2:A" & lastRow).Copy
destrow = Sheets("Unknown").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Unknown").Select
    Range("A" & destrow).Select
    ActiveSheet.Paste
End If
Next sheetname
    
End Sub