Copy Column Range if "Y" is in Column

helpexcel

Well-known Member
Joined
Oct 21, 2009
Messages
656
Hi - I have a spread sheet where you will enter a "Y" or "N" in row 45. I then want to be able to hit a button that will create a new sheet named "option 1" where I27:O24 will be copied to A1 and I38:J115 to A12 on the new sheet. Then any column with a "Y" in row 45 will have that column from row 38 - 115 will be copied to the next available column in row 12 on the new sheet. The sheet naming doesn't work, I want it to name sheets Option 1,2,3...as new sheets are added. It seems to loop through the range, but only pastes the final column.


VBA Code:
Set ws1 = Sheet9
Dim ws As Worksheet
iStart = 1

With ws1
    Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = "Option " & iStart.Value
            On Error GoTo 0
     .Range("I27:X38").COPY
        With ws.Range("A1")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With

     '.Range("I38:J115").SpecialCells(xlCellTypeVisible).COPY
     .Range("I38:J137").COPY
        With ws.Range("A12")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            
            Range("A13:B17").Delete Shift:=xlUp
            
        End With
 
End With

    Dim C As Long, LR As Long, LC As Long, SC As Long

    With ws1
        LR = .Cells(.Rows.Count, 9).End(xlUp).Row
        LC = .Cells(44, .Columns.Count).End(xlToLeft).Column
        
           For C = 1 To LC
           For i = 3 To LC
          
                If .Cells(45, C) = "Y" Then
                    .Range(.Cells(44, C), .Cells(137, C)).COPY
                    With ws.Cells(13, i)
                        .PasteSpecial Paste:=xlPasteColumnWidths
                        .PasteSpecial Paste:=xlPasteFormats
                        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        Application.CutCopyMode = False
                    End With
                End If
            Next i
            Next C
    End With
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
I keep trying all of the previous codes I've used, but I just can't get this to work. Any help would be appreciated.
 
Upvote 0
Failing at every step. this is my latest attempt.
VBA Code:
Set ws1 = Sheet9
Dim ws As Worksheet
iStart = 1

With ws1
    Sheets.Add After:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = "Option " & iStart.Value
            On Error GoTo 0
     .Range("I27:X38").COPY
        With ws.Range("A1")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With

     '.Range("I38:J115").SpecialCells(xlCellTypeVisible).COPY
     .Range("I38:J137").COPY
        With ws.Range("A12")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            
            Range("A13:B17").Delete Shift:=xlUp
            
        End With
 
End With

    Dim LR As Long, LC As Long, SC As Long
    Dim i As Integer
    Dim C As Range

SC = ws.Cells(15, ws.Columns.Count).End(xlToLeft).Column
    If SC > 1 Then
        SC = SC + 1
    End If

    With ws1
        LR = .Cells(.Rows.Count, 9).End(xlUp).Row
        LC = .Cells(44, .Columns.Count).End(xlToLeft).Column
    
         For i = 10 To LC
           For Each C In .Range(.Cells(44, 10), .Cells(44, LC))
                    
                If C.Value = "Y" Then
                    .Range(.Cells(44, C), .Cells(137, C)).COPY
                    With ws.Cells(13, SC)
                        .PasteSpecial Paste:=xlPasteColumnWidths
                        .PasteSpecial Paste:=xlPasteFormats
                        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        Application.CutCopyMode = False
                    End With
                End If
            Next C
            Next i
    End With
 
Upvote 0
Getting a type mismatch error on the strconvo line...
VBA Code:
Dim lastRow, lastColumn, SC As Long

lastRow = ws1.Range("I" & ws1.Rows.Count).End(xlUp).Row

SC = ws.Cells(15, ws.Columns.Count).End(xlToLeft).Column
    If SC > 1 Then
        SC = SC + 1
    End If

For lastColumn = 10 To ws1.Cells(45, ws1.Columns.Count).End(xlToLeft).Column
        If StrConv(ws1.Range(ws1.Cells(45, 10), ws1.Cells(45, lastColumn).Cells), vbProperCase) = "Y" Then
            ws.Range("K" & lastRow).COPY
                    With ws.Cells(13, SC)
                        .PasteSpecial Paste:=xlPasteColumnWidths
                        .PasteSpecial Paste:=xlPasteFormats
                        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        Application.CutCopyMode = False
                    End With
                End If
            Next lastColumn
 
Upvote 0
Getting closer, this works but how do i change the paste code to a selected range and not the enitre column? keep getting an "object doesn't support" error.

VBA Code:
Dim cel As Range
Dim count As Long

count = 1

For Each cel In ws1.[45:45]

    If cel = "Y" Then
        cel.EntireColumn.Copy ws.Cells(13, count)
        count = count + 1
    End If
       
Next cel
 
Upvote 0
Getting closer, this works but how do i change the paste code to a selected range and not the enitre column? keep getting an "object doesn't support" error.
Can you provide a concrete example of exactly it is what you are trying to do with this part of the code?
Please include the details, such as cell addresses, etc.
 
Upvote 0
i have 2 sheets. Sheet 1 will have the data i want to copy. I'm copying I27:N34 & I38:J137 to sheet2. I then want to look in row 45, to see if there is a "Y" or "N". if there is a "Y" i want to copy the column its in from 44:137 to column C on sheet2. There are multiple columns on sheet 1, so that needs to variable, and it needs to find the next empty column after C on sheet 2.
 
Upvote 0
Firstly, you do NOT want to loop through every single column on row 45. That will cause a lot of unnecessary loops and slow down your code.
You only want to go as far as the last populated column on row 45.

So, if I understand you correctly, I think this code should work for the task you are trying to accomplish with your last bit of code:
VBA Code:
    Dim lc As Long
    Dim c As Long
    Dim sc As Long

    Application.ScreenUpdating = False

'   Set default starting column to paste to (column C = 3)
    sc = 3

'   Find last column on row 45 with data
    lc = Cells(45, Columns.count).End(xlToLeft).Column

'   Loop through all columns on row 45
    For c = 1 To lc
    
'       Check to see if value is "Y"
        If Cells(45, c) = "Y" Then
'           Copy from column between rows 44:137 to ws, starting in column C
            Range(Cells(44, c), Cells(137, c)).Copy ws.Cells(1, sc)
'           Increment paste to column counter
            sc = sc + 1
        End If
        
    Next c

    Application.ScreenUpdating = True
 
Upvote 0
Solution
THANK YOU!! I appreciate the help

I tweaked the code slightly, but it works great.

VBA Code:
Dim lc As Long
Dim c As Long
Dim sc As Long

'   Set default starting column to paste to (column C = 3)
    sc = 3

'   Find last column on row 45 with data
    lc = ws1.Cells(45, Columns.count).End(xlToLeft).Column

With ws1

'   Loop through all columns on row 45
    For c = 1 To lc
        
'       Check to see if value is "Y"
        If .Cells(45, c) = "Y" Then
'           Copy from column between rows 44:137 to ws, starting in column C
            .Range(.Cells(44, c), .Cells(137, c)).COPY
                With ws.Cells(13, sc)
                    .PasteSpecial Paste:=xlPasteColumnWidths
                    .PasteSpecial Paste:=xlPasteFormats
                    .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False
                End With
'           Increment paste to column counter
            sc = sc + 1
        End If
        
    Next c

End With
 
Upvote 0
You are welcome.
Glad I was able to help!
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,238
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top