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
Microsoft ExcelVB Script

Avatar of undefined
Last Comment
Martin Liss

8/22/2022 - Mon
Martin Liss

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
Martin Liss

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
SixSigmaGuy

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
SixSigmaGuy

MartinLiss: see my line where I set iLastCol.  It solves the problem of speed when you don't know how many columns contain data.
All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck
Martin Liss

Thanks and yes I know of that technique. I just didn't think of it.
terencino

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
Martin Liss

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

Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
carlosab

Thanks. Works great.
Martin Liss

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

Marty - MVP 2009 to 2013