Private Sub CommandButton1_Click()
    
Dim r As Range, lr As Long
    With Sheet1
        Application.Goto .Range("A6")
        ActiveCell.Offset(1, 0).Select
        Do Until ActiveCell.EntireRow.Hidden = False
            ActiveCell.Offset(1, 0).Select
        Loop
        lr = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row + 1
        For Each r In Intersect(Selection.EntireColumn, .AutoFilter.Range.SpecialCells(12))
            Sheet2.Cells(lr, 2).Value = r.Value
            lr = lr + 1
        Next r
    End With
        Dim nextRow As Long
        nextRow = Sheets("sheet2").Range("B10000").End(xlUp).Row
        With ThisWorkbook.Sheets("sheet2")
                      .Range("C" & nextRow).Value = Sheets("sheet1").Range("F5").Value
        End With
        If TextBox1.Value = "" Then
        MsgBox ("Enter Destination")
        Exit Sub
        Else
        Sheet1.Range("A1:B260").PrintOut
    
End If
    TextBox1.Value = ""
ActiveSheet.TextBox1.Activate
End Sub

المشاركة الأصلية كتبت بواسطة: حسين مامون ربما

CODE

Private Sub CommandButton1_Click()      Dim r As Range, lr As Long     With Sheet1         Application.Goto .Range("A6")         ActiveCell.Offset(1, 0).Select         Do Until ActiveCell.EntireRow.Hidden = False             ActiveCell.Offset(1, 0).Select         Loop         lr = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row + 1         For Each r In Intersect(Selection.EntireColumn, .AutoFilter.Range.SpecialCells(12))             Sheet2.Cells(lr, 2).Value = r.Value             lr = lr + 1         Next r     End With         Dim nextRow As Long         nextRow = Sheets("sheet2").Range("B10000").End(xlUp).Row         With ThisWorkbook.Sheets("sheet2")                       .Range("C" & nextRow).Value = Sheets("sheet1").Range("F5").Value         End With         If TextBox1.Value = "" Then         MsgBox ("Enter Destination")         Exit Sub         Else         Sheet1.Range("A1:B260").PrintOut      End If     TextBox1.Value = "" ActiveSheet.TextBox1.Activate End Sub