زيادة عدد الاعمده اكثر من10 فى الترحيل للست

Const Cont As Integer = 13

Private Sub CommandButton7_Click()

Dim Ary()

Dim r As Long, rr As Long, Lr As Long

Dim c As Integer

With Me.ListBox1

If .ListCount = 0 Then GoTo 8

8 i = .ListCount

        For i = 1 To 1

               rr = rr + 1

            ReDim Preserve Ary(1 To Cont, 1 To rr)

            For c = 1 To Cont

                Ary(c, rr) = Me.Controls("a" & c).Value

            Next

    Next

End With

If rr Then Me.ListBox1.Column = Ary

End Sub

Private Sub CommandButton7_Click()

Dim Ro

Const Col = 12

 Ro = Cells(Rows.Count, 1).End(3).Row + 1

 Me.ListBox1.RowSource = Range("A1:L" & Col).Address

End Sub

Private Sub To_sheet_Click()

 Dim Ro, i

 Const Col = 12

 Ro = Cells(Rows.Count, 1).End(3).Row + 1

    For i = 1 To Col

     ActiveSheet.Cells(Ro, i) = Me.Controls("a" & i)

    Next

  CommandButton7_Click

End Sub

Private Sub To_sheet_Click()

 Dim Ro, i

 Const Col = 13

 Ro = Cells(Rows.Count, 1).End(3).Row + 1

    For i = 1 To Col

     ActiveSheet.Cells(Ro, i) = Me.Controls("a" & i)

    Next

    Me.ListBox1.RowSource = ""

    Me.ListBox1.RowSource = Range("A" & Ro - 1).Resize(, 13).Address



End Sub

'Dim r As Long, rr As Long, Lr As Long

'Dim c As Integer

'With Me.ListBox1

''If .ListCount = 0 Then GoTo 8

''8

'i = .ListCount

'        For g = i To i

'               rr = rr + 1

'            ReDim Preserve Ary(1 To Cont, 1 To rr)

'            For c = 1 To Cont

'                Ary(c, rr) = Me.Controls("a" & c).Value

'            Next

'    Next

Private Sub Cmd_Clear_Click()

Dim k As Long

Me.ListBox1.Clear

For k = 1 To 13

   Me.Controls("a" & k) = vbNullString

 Next

End Sub

'++++++++++++++++++++++++++++++++++++++++++



Private Sub To_sheet_Click()

Dim k As Long, lr As Long

lr = ActiveSheet.Cells(Rows.Count, 1).End(3).Row + 1

 If lr = 1 Then lr = 2

 For k = 1 To 13

   ActiveSheet.Cells(lr, k) = Me.Controls("a" & k)

 Next

    With Me.ListBox1

        If .ListCount = 0 Then

            FirstRow

        Else

            NextRow

        End If

    End With



End Sub

'+++++++++++++++++++++++++++++++++



Private Sub FirstRow()



    Dim arr() As Variant

    Dim i As Long



With Me.ListBox1

        ReDim arr(1 To 1, 1 To .ColumnCount)

    For i = LBound(arr, 2) To UBound(arr, 2)

        arr(1, i) = Me.Controls("a" & i).Value

    Next i



   .List = arr()

End With

End Sub

'""""""""""""""""""""""""""""""""



Private Sub NextRow()



    Dim arr() As Variant

    Dim i As Long



    With Me.ListBox1

        arr() = Application.Transpose(.List())

       ReDim Preserve arr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)

         For i = LBound(arr, 1) To UBound(arr, 1)

            arr(i, UBound(arr, 2)) = Me.Controls("a" & i).Value

        Next i

       .List = Application.Transpose(arr())

    End With



End Sub