VBA Code needed

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

Select allOpen in new window

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

Select allOpen 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

Select allOpen in new window

Thanks. Works great.

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

Marty - MVP 2009 to 2013