Macro: Copy entire column into new sheets based on criteria listed in range in another sheet (excel 2010)

[RyndaRaw]

Hi,

I need help trying to create a macro.

I have column Row 1 - Headers - User name.
I want to create a macro that will copy the entire column into a new sheet IF the name in Row 1 matches a range of approved user names in another sheet.

See below example:

Input Sheet						Approved Name Sheet		Return Approved Names with all column values on New Sheet
Value	Name 1	Name 2	Name 3	Name 4		Approved Names		Value	Name 1	Name 4
Alpa	X		X			Name 1		Alpa	X
Beta		X		T		Name 4		Beta		T
Gamma	XX			X				Gamma	XX	X

 

[JLGWhiz]

You will need to edit the sheet names and possibly the rows, It was unclear if everything started in row 1 on all three sheets.

Sub at()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range
Set sh1 = Sheets("Input")
Set sh2 = Sheets("Approved Name")
Set sh3 = Sheets("Return Approved Names")
    With sh1
        For Each c In .Range("B1", .Cells(1, Columns.Count).End(xlToLeft))
            If Application.CountIf(sh2.Range("A:A"), c.Value) > 0 Then
                Intersect(c.EntireColumn, .UsedRange).Copy sh3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
            End If
        Next
    End With
End Sub

 

[RyndaRaw]

You will need to edit the sheet names and possibly the rows, It was unclear if everything started in row 1 on all three sheets.

Sub at()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range
Set sh1 = Sheets("Input")
Set sh2 = Sheets("Approved Name")
Set sh3 = Sheets("Return Approved Names")
    With sh1
        For Each c In .Range("B1", .Cells(1, Columns.Count).End(xlToLeft))
            If Application.CountIf(sh2.Range("A:A"), c.Value) > 0 Then
                Intersect(c.EntireColumn, .UsedRange).Copy sh3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
            End If
        Next
    End With
End Sub

Hi Mr. Whiz ,

the macro worked, I forgot to include that I needed all rows for the description columns (Desc 1 to 4 are Columns A to D) to get returned with the columns (that matched the names from the approved tab).

Everything does start in row 1 on all 3 sheets. They all have headers in Row 1.

When I ran the macro - I did get an error though. It's a pretty big file and it has to search through 200K+ rows and columns. I know this could be a limitation of using macros. Any thoughts on how I can execute on such a large file?

Desc 1	Desc 2	Desc 3	Desc 4	Name 1	Name 2	Name 3	Name 4
Red	Wide	Tall	Polka	Todd	Meg	John	Laine

Thank you so much, I'm pretty new to macros/vba and have spent weeks trying to write what you wrote so quickly

 

[JLGWhiz]

This will adjjust for the four description columns as far as copying the correct columns.

Sub at()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range
Set sh1 = Sheets("Input")
Set sh2 = Sheets("Approved Name")
Set sh3 = Sheets("Return Approved Names")
    With sh1
        For Each c In .Range("E1", .Cells(1, Columns.Count).End(xlToLeft))
            If Application.CountIf(sh2.Range("A:A"), c.Value) > 0 Then
                Intersect(c.EntireColumn, .UsedRange).Copy sh3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
            End If
        Next
    End With
End Sub

I suggest that for copying the data in columns A:D of the input sheet, that you start a new thread since ithe "Oh I forgot" exceeds the scope of the original post, and there is insuffucient detail to know if exactly what descriptive data you want to copy over, nor where you want it pasted on the Return sheet.

 

[RyndaRaw]

This will adjjust for the four description columns as far as copying the correct columns.

Sub at()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, c As Range
Set sh1 = Sheets("Input")
Set sh2 = Sheets("Approved Name")
Set sh3 = Sheets("Return Approved Names")
    With sh1
        For Each c In .Range("E1", .Cells(1, Columns.Count).End(xlToLeft))
            If Application.CountIf(sh2.Range("A:A"), c.Value) > 0 Then
                Intersect(c.EntireColumn, .UsedRange).Copy sh3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
            End If
        Next
    End With
End Sub

I suggest that for copying the data in columns A:D of the input sheet, that you start a new thread since ithe "Oh I forgot" exceeds the scope of the original post, and there is insuffucient detail to know if exactly what descriptive data you want to copy over, nor where you want it pasted on the Return sheet.

Macro: Copy entire column into new sheets based on criteria listed in range in another sheet AND also first 4 columns copied onto new sheet | MrExcel Message Board

I just posted a new thread with the additional scope.

Thanks JLGWhiz.

 

[JLGWhiz]

Thank you for the feedback,
Regards, JLG