Link to home
Start Free TrialLog in
Avatar of carlosab
carlosab

asked on

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
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

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

ASKER CERTIFIED SOLUTION
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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
MartinLiss: see my line where I set iLastCol.  It solves the problem of speed when you don't know how many columns contain data.
Thanks and yes I know of that technique. I just didn't think of it.
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
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

Avatar of carlosab
carlosab

ASKER

Thanks. Works great.
Once again you're welcome and I'm glad I was able to help.

Marty - MVP 2009 to 2013