VBA Code needed

A user will select a cell in a worksheet. After the cell is selected, I need code that will:

1. Hide columns Blue:Green (where "Blue" and "Green" are each names that I've defined for the columns in the worksheet)

2. Copy the visible cells in the row that contains the cell that the user had selected

3. Insert the copied data to the second row on a sheet that's been named "Paid"

Thanks.
Exchange.xlsx
carlosabAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
If this works please don't assign me any points since I consider it a continuation of the previous question.
Sub Paid()

Dim ws As Worksheet
Dim lngCol As Long
Dim cel As Range
Dim rng As Range

Set ws = Worksheets("Main")
With ws
    Worksheets("Paid").Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    .Range("Blue" & ":" & "Green").EntireColumn.Hidden = True
    ActiveCell.EntireRow.Select

    Set rng = Selection.Cells.SpecialCells(xlCellTypeVisible)
    
    For Each cel In rng
        lngCol = lngCol + 1
        Worksheets("Paid").Cells(2, lngCol) = cel
    Next
End With
End Sub

Open in new window

0
Martin LissOlder than dirtCommented:
I remember that in the other thread you said it took a few seconds to run and that's true, the reason being that it was looking in the entire row for visible cells and there are a lot of cells in a row. So here's faster version.

Sub Paid()

Dim ws As Worksheet
Dim lngCol As Long
Dim cel As Range
Dim rng As Range

Set ws = Worksheets("Main")
With ws
    Worksheets("Paid").Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    .Range("Blue" & ":" & "Green").EntireColumn.Hidden = True
    'ActiveCell.EntireRow.Select
    ' This looks at columns A to F. If there can be columns after F then change 6 to a higher number.
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 6)).Select
    Set rng = Selection.Cells.SpecialCells(xlCellTypeVisible)
    
    For Each cel In rng
        lngCol = lngCol + 1
        Worksheets("Paid").Cells(2, lngCol) = cel
    Next
End With
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SixSigmaGuyCommented:
Note, I had to rename the file to have an XLSM extension.  Also, wasn't sure how you
wanted to copy the cells to the destination, so I wrote two versions.  See the
OPTION1 constant.
-------------------------------------------------------
Option Explicit
#Const OPTION1 = 1 ' See code below to set this value before running code.
Sub CarlosAb()
    Dim ws As Excel.Worksheet
    Dim wsPaid As Excel.Worksheet
    Dim r As Excel.Range
    Dim rSelected As Excel.Range
    Dim iLastCol As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim iDestCol As Long
   
    Set ws = Me
    Set wsPaid = ThisWorkbook.Worksheets("Paid")
   
   
    Set r = ws.Range("Blue:Green")
    Set rSelected = ws.Application.Selection
    If rSelected.Rows.Count = 1 Then
        Stop
        ' Error condition since I won't know what row to copy if the user has
        ' selected more than one row or didn't select any rows
        Exit Sub
    End If
    iRow = rSelected.Row
    r.Columns.Hidden = True
   
    iLastCol = ws.Cells(iRow, ws.Columns.Count).End(xlToLeft).Column  ' This line is not needed
                                                                             ' if you are always going to
                                                                             ' have only 6 columns.  Just
                                                                             ' use iLastCol = 6 instead.
                                                                             
    wsPaid.Rows(2).Insert xlShiftDown
#If OPTION1 = 1 Then
    '
    ' Option 1 - as you described it.
    '
    For iCol = 1 To iLastCol
        If ws.Columns(iCol).Hidden = False Then
            wsPaid.Cells(2, iCol) = ws.Cells(iRow, iCol)
        End If
    Next iCol
#Else
    '
    ' Option 2 - as I think you meant it.
    '
    iDestCol = 1
    For iCol = 1 To iLastCol
        If ws.Columns(iCol).Hidden = False Then
            wsPaid.Cells(2, iDestCol) = ws.Cells(iRow, iCol)
            iDestCol = iDestCol + 1
        End If
    Next iCol
#End If
End Sub
0
CompTIA Network+

Prepare for the CompTIA Network+ exam by learning how to troubleshoot, configure, and manage both wired and wireless networks.

SixSigmaGuyCommented:
MartinLiss: see my line where I set iLastCol.  It solves the problem of speed when you don't know how many columns contain data.
0
Martin LissOlder than dirtCommented:
Thanks and yes I know of that technique. I just didn't think of it.
0
terencinoCommented:
This option uses a worksheet event to transfer the data to the Paid sheet. So the user just needs to click on one of the names in the first column, a message box will pop up asking if you want to transfer the data, and if so will perform the rest of the requirements.
...Terry
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 1 And Target.Value <> "" Then
    retval = MsgBox("Record " & Target.Value & " as paid?", vbYesNo, "Pay Master")
    If retval = vbNo Then
        'do nothing
    Else
        Range("Blue:Green").EntireColumn.Hidden = True
        Sheets("Paid").Rows("2:2").Insert Shift:=xlDown
        With Rows(ActiveCell.Row).SpecialCells(xlCellTypeConstants, 23)
             .SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Paid").Range("A2")
        End With
    End If
End If
Application.EnableEvents = True
End Sub

Open in new window

Exchange.xlsm
0
Martin LissOlder than dirtCommented:
This finds the last column


Sub Paid()

Dim ws As Worksheet
Dim lngCol As Long
Dim cel As Range
Dim rng As Range
Dim LastColumn As Long

Set ws = Worksheets("Main")
With ws
    Worksheets("Paid").Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    LastColumn = .Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
    .Range("Blue" & ":" & "Green").EntireColumn.Hidden = True
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, LastColumn)).Select
    Set rng = Selection.Cells.SpecialCells(xlCellTypeVisible)
    
    For Each cel In rng
        lngCol = lngCol + 1
        Worksheets("Paid").Cells(2, lngCol) = cel
    Next
End With
End Sub

Open in new window

0
carlosabAuthor Commented:
Thanks. Works great.
0
Martin LissOlder than dirtCommented:
Once again you're welcome and I'm glad I was able to help.

Marty - MVP 2009 to 2013
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.