VBA copy column only when value is 1 in row 1

[NickvdB]

Hello,

Excel 2010:
I would like to use a VBA with the following code
Workbooks("AAA.xlsb").Worksheets("BBB").Range("VARIABLE").Copy Destination:=Workbooks("CCC.xlsb").Worksheets("BBB").Range("a1")
the red part should be based on the values of row 1. So as an example following cell values: A1=1 / B1=1 / D1=1 / G1=1
Then I would like to have rows A + B + D + G in the red part.
Hope this makes sense and somebody can help

 

[NickvdB]

What excel version are you using? 2003?

2010, but I think the moving of the columns is causing the long waiting time, therefore I might think deleting of columns with not 1 could work quicker.

 

[Arithos]

Hmm, you want it to move all information, then delete?

 

[jasonb75]

Nick, this is the revised code that I Tried to post a few minutes ago.

Option Explicit
Sub copy1()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
Dim c As Range, rng As Range
With Workbooks("AAA.xlsb").Sheets("BBB")
    For Each c In Intersect(.Range("1:1"), .UsedRange)
        If c.Value = 1 Then
            If Not rng Is Nothing Then
                Set rng = Union(rng, Intersect(c.EntireColumn, .UsedRange))
            Else
                Set rng = Intersect(c.EntireColumn, .UsedRange)
            End If
        End If
    Next
End With
If Not rng Is Nothing Then rng.Copy Workbooks("CCC.xlsb").Sheets("BBB").Range("A1")
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

 

[Arithos]

Thumbs up to Jason

 

[NickvdB]

Nick, this is the revised code that I Tried to post a few minutes ago.

Option Explicit
Sub copy1()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
Dim c As Range, rng As Range
With Workbooks("AAA.xlsb").Sheets("BBB")
    For Each c In Intersect(.Range("1:1"), .UsedRange)
        If c.Value = 1 Then
            If Not rng Is Nothing Then
                Set rng = Union(rng, Intersect(c.EntireColumn, .UsedRange))
            Else
                Set rng = Intersect(c.EntireColumn, .UsedRange)
            End If
        End If
    Next
End With
If Not rng Is Nothing Then rng.Copy Workbooks("CCC.xlsb").Sheets("BBB").Range("A1")
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Looks very promising! Could you help me with two perfections:
1) How to paste this as values?
2) How to have not the complete column copied but from row 5 till 2000?
Thanks so far!

 

[jasonb75]

Try this version,

Option Explicit
Sub copy1()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
Dim c As Range, rng As Range
With Workbooks("AAA.xlsb").Sheets("BBB")
    For Each c In Intersect(.Range("1:1"), .UsedRange)
        If c.Value = 1 Then
            If Not rng Is Nothing Then
                Set rng = Union(rng, Intersect(c.EntireColumn, .Range("5:2000")))
            Else
                Set rng = Intersect(c.EntireColumn, .Range("5:2000"))
            End If
        End If
    Next
End With
If Not rng Is Nothing Then rng.Copy
    Workbooks("CCC.xlsb").Sheets("BBB").Range("A1").PasteSpecial xlValues
    .CutCopyMode = False
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Do you need any formatting copied as well?

 

[NickvdB]

No not needed, only values.

 

[NickvdB]

Try this version,

Option Explicit
Sub copy1()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
Dim c As Range, rng As Range
With Workbooks("AAA.xlsb").Sheets("BBB")
    For Each c In Intersect(.Range("1:1"), .UsedRange)
        If c.Value = 1 Then
            If Not rng Is Nothing Then
                Set rng = Union(rng, Intersect(c.EntireColumn, .Range("5:2000")))
            Else
                Set rng = Intersect(c.EntireColumn, .Range("5:2000"))
            End If
        End If
    Next
End With
If Not rng Is Nothing Then rng.Copy
    Workbooks("CCC.xlsb").Sheets("BBB").Range("A1").PasteSpecial xlValues
    .CutCopyMode = False
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Do you need any formatting copied as well?

Tested and works like a charm!!!!! Thanks