If a cell is > 10 copy and paste colum to sheet 2

Question

I'm working on an Excel 2007 Spreadsheet for work and I need to take a value on 'Sheet 1' and IF its larger then 10, I need to take an entire column and past it to 'Sheet 2'.

How would I do this? Where would I start?

UPDATE:

Sub TopComp()


For Each i In Worksheets("All Competition").Range("E32:BL32")
 If i.Value > 9 Then
 ady = i.EntireColumn.Cells(1).Address
 i.EntireColumn.Copy Sheets("Top 10 Competition").Range(ady)
 End If
Next i

End Sub

The problem I am having now is when it paste the colum, which is awesome. It is leaving spaces for the empty ones. Is there a way to fix that?

Answer 1

EDIT #1, pictures from last post removed

OK, let's try this instead. You start out with a workbook like this:

Try running this modification of your code:

Sub TopComp()

Dim i As Range, TargetRng As Range
Dim TargetCounter As Long
Dim AllSheet As Worksheet, TopSheet As Worksheet

'declare worksheets for easy reference
Set AllSheet = ThisWorkbook.Worksheets("All Competition")
Set TopSheet = ThisWorkbook.Worksheets("Top 10 Competition")

For Each i In AllSheet.Range("E32:BL32")
    If i.Value > 9 Then
        TargetCounter = TargetCounter + 1
        Set TargetRng = TopSheet.Cells(1, TargetCounter).EntireColumn
        i.EntireColumn.Copy TargetRng
    End If
Next i

End Sub

That should give you to the following, which is what I think you want:

--

Cool -- let's say you start with the workbook looking like this:

You can run this code to populate with the columns that have an end value > 10:

Option Explicit
Sub CheckColumns()

Dim LastCol As Long, LastRow As Long, _
    ColIdx As Long, TargetColCounter As Long
Dim SheetOne As Worksheet, SheetTwo As Worksheet
Dim ColRng As Range, TargetRng As Range

'assign sheets for easy reference
Set SheetOne = ThisWorkbook.Worksheets("Sheet1")
Set SheetTwo = ThisWorkbook.Worksheets("Sheet2")

'identify the last row and last column to set bounds on loop
LastRow = SheetOne.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = SheetOne.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

'loop through the columns
For ColIdx = 1 To LastCol

    If SheetOne.Cells(LastRow, ColIdx).Value > 10 Then
        TargetColCounter = TargetColCounter + 1
        Set ColRng = Range(SheetOne.Cells(1, ColIdx), SheetOne.Cells(LastRow, ColIdx))
        Set TargetRng = Range(SheetTwo.Cells(1, TargetColCounter), SheetTwo.Cells(LastRow, TargetColCounter))
        ColRng.Copy TargetRng
    End If

Next ColIdx

End Sub

Answer 2

Select the test cell on the first sheet and run:

Sub kolumnizer()
    If ActiveCell.Value > 10 Then
        ady = ActiveCell.EntireColumn.Cells(1).Address
        ActiveCell.EntireColumn.Copy Sheets("Sheet2").Range(ady)
    End If
End Sub

NOTE:

I am using Sheet2 rather than Sheet 2

EDIT#1:

This version will loop over all the columns in the first sheet and copy the column to Sheet2 if some cell in the column has a value greater than 10:

Sub kolumnizer()
    Dim i As Long, wf As WorksheetFunction
    Dim nLastColumn As Long, nFirstColumn As Long
    Set wf = Application.WorksheetFunction
    Set r = ActiveSheet.UsedRange
    nLastColumn = r.Columns.Count + r.Column - 1
    nFirstColumn = r.Column
    For i = nFirstColumn To nLastColumn
        Set r = Cells(1, i).EntireColumn
        If wf.Max(r) > 10 Then
            r.Copy Sheets("Sheet2").Cells(1, i)
        End If
    Next i
End Sub

Start on the first sheet

EDIT#2

Version 3 allows you to pick the range:

Sub kolumnizer3()
    Dim i As Long, wf As WorksheetFunction
    Dim nLastColumn As Long, nFirstColumn As Long
    Set wf = Application.WorksheetFunction
    Set r = Application.InputBox(Prompt:="Pick your range", Type:=8)
    nLastColumn = r.Columns.Count + r.Column - 1
    nFirstColumn = r.Column
    For i = nFirstColumn To nLastColumn
        Set r = Cells(1, i).EntireColumn
        If wf.Max(r) > 10 Then
            r.Copy Sheets("Sheet2").Cells(1, i)
        End If
    Next i
End Sub