Copy and Paste distinct columns macro

[mopgcw]

Hey folks,

I need your help again. I have a data on Sheet1 such as:

A B C D E
1 1 2 3 4 5
2 1 0 1 1 0
3 D1 D2 D3 D4 D5
2 D6 D7 D8 D9 D10
3 D11....

Row 1 specifies the number of columns to include in the review = 5
Row 2 indicates whether to copy the column 1=yes; 0=no

So I need the macro to loop through the columns and copy Column A to the
specified range on Sheet 2; then Column C to the next open Column in Sheet 2,
the Column D etc...

here is the code I have so far:

Sub ColumnCopy()

' Initialize Variables

Dim TheRangeName As String
Dim ColLoop As Integer
Dim F As Integer
Dim TotNumCol As Integer
Dim ColIncluded As Integer

NumCols = WorksheetFunction.Max(Range("array_colnum").Value)

' Clear contents of the range where data will be pasted on sheet 2.

Range("Analysis_Range").ClearContents

TotNumCol = 0
ColIncluded = 0

' Loop through each column

Application.Goto Reference:=Range("col_id_start"), Scroll:=True

For ColLoop = 1 To NumCols

If Range("Array_ColInclude").Cells(ColLoop) = 1 Then

'========================================
'Copy & Paste each Column
'========================================

For F = 1 To 500

If Range("col_id_start").Cells(F).Value > 0 Then

ColIncluded = ColIncluded + 1

Range(Selection, Selection.End(xlDown)).Select

ActiveWorkbook.Names.Add Name:="TheRangeName",
RefersTo:=Selection

Range(TheRangeName).Copy

Range("analysis_range").Cells(TotNumCol - ColIncluded +
1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False,
Transpose:=False

End If
Next F

End If

Next ColLoop

Range("A1").Copy ' JUST TO CLEAR CLIPBOARD
Application.CutCopyMode = False

Application.DisplayAlerts = True
MsgBox ("Copied " + WorksheetFunction.Text(ColIncluded, "0") + " Columns")

End Sub

The code is getting hung up on: "Range(TheRangeName).Copy"



TIA for your insights and assistance.

George

 

[Sheeloo]

Here is the barebones version...
Clear Sheet2 then look for a number in A1 on Sheet1
Then for columns 1 - to the number in A1
look for 1 in row 2 of the column
If found copy the entire column to the next available column in Sheet2,
starting from Col A
'
Sub copyCol()
Dim nCols As Long
Dim i, j As Long
nCols = Range("A1")
j = 1
Worksheets("Sheet2").UsedRange.ClearContents
For i = 1 To nCols
If Cells(2, i) = 1 Then
Columns(i).EntireColumn.Copy _
Destination:=Worksheets("Sheet2").Cells(1, j)
j = j + 1
End If
Next
End Sub

 

[mopgcw]

THANKS! This was very helpful.

Take Care,
George