ذخیره فرم با تغییر شماره فاکتور جدید

[sepahan2006]

سلام به همه دوستان
یک فاکتور فروشی هستش که میخوام از طریق ماکرو یا ابزار های developer طوری برنامه نویسی کنم که وقتی شماره فاکتور را اضافه میکنم فاکتور جدید ایجاد شود اطلاعات مربوط به فاکتور وارد شود و سپس ذخیره و فاکتور بعدی، نیاز نباشه برای هر فاکتور یک شیت جداگانه ایجاد کنم. ممنونم میشم راهنمایی کنید؟

[rasools13]

سلام به همه دوستان
یک فاکتور فروشی هستش که میخوام از طریق ماکرو یا ابزار های developer طوری برنامه نویسی کنم که وقتی شماره فاکتور را اضافه میکنم فاکتور جدید ایجاد شود اطلاعات مربوط به فاکتور وارد شود و سپس ذخیره و فاکتور بعدی، نیاز نباشه برای هر فاکتور یک شیت جداگانه ایجاد کنم. ممنونم میشم راهنمایی کنید؟

سلام فایل پیوست را بررسی کنید..
سه دکمه جدید، پاک کردن فاکتور و ذخیره فاکتور با کد های ذیل براتون آماده شده و محدودیتی در تعداد سطرهای فکتور نداره
کد دکمه جدید: پاک کردن و آماده سازی فاکتور و تعیین شماره فاکتور جدید

Sub NewFactor()
'
' Macro1 Macro
'

'
    Dim wsh As Worksheet
    Dim i, j As Integer
    Set wsh = ActiveSheet
    With wsh.ListObjects("Table1")
        j = .ListRows.Count
        For i = 2 To j Step 1
            .ListRows(i).Delete
            i = 1
            If .ListRows.Count = 1 Then
                Exit For
            End If
        Next
        .Range(2, 1) = "=ROW(A6)-5"
        .Range(2, 2) = ""
        .Range(2, 3) = ""
        .Range(2, 4) = ""
        .Range(2, 5) = ""
    End With
    Range("F4") = Range("F4") + 1
End Sub 

کد دکمه پاک کردن: پاک کردن و فرم فکتور حاضر

Sub ClearForm()
'
' Macro1 Macro
'

'
    Dim wsh As Worksheet
    Dim i, j As Integer
    Set wsh = ActiveSheet
    With wsh.ListObjects("Table1")
        j = .ListRows.Count
        For i = 2 To j Step 1
            .ListRows(i).Delete
            i = 1
            If .ListRows.Count = 1 Then
                Exit For
            End If
        Next
        .Range(2, 1) = "=ROW(A6)-5"
        .Range(2, 2) = ""
        .Range(2, 3) = ""
        .Range(2, 4) = ""
        .Range(2, 5) = ""
    End With
End Sub 

کد دکمه ذخیره: ذخیره کردن فاکتور

Sub SaveFactor()
'
' Macro1 Macro
'

'
    Dim wsh As Worksheet
    Dim i, j, f, h As Integer
    i = 5
    j = 2
    Set wsh = ActiveSheet
    With wsh.ListObjects("Table1")
        For f = 0 To 1000 Step 1
            h = .ListRows.Count + 2
            If Cells(i, j) = "" Then
                Range(Cells(4, 2), Cells(h + 3, 6)).Copy
                Cells(i - 1, j).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
                Exit For
            Else
                j = j + 7
            End If
        Next
    End With
End Sub 

فاکتور برای اجاری کدها باید درقالب Table باشد

[generalsamad]

با سلام
این هم یه نمونه دیگه

Sub sabt()
On Error Resume Next
    Dim lrow As Integer
    lrow = Sheet2.Cells(Sheet2.Rows.Count, "a").End(xlUp).Row + 1
    fr = Application.WorksheetFunction.Match(Sheet1.Range("g3"), Sheet2.Range("a:a"), False)
    If (fr > 0) Then
        MsgBox ("in factor mojood mibashad")
    Else
        Sheet2.Cells(lrow, 1).Value = Sheet1.Range("g3")
        Sheet2.Cells(lrow, 2).Value = Sheet1.Range("c3")
        Sheet2.Cells(lrow, 3).Value = Sheet1.Range("c5")
        Sheet2.Cells(lrow, 4).Value = Sheet1.Range("d5")
        Sheet2.Cells(lrow, 5).Value = Sheet1.Range("e5")
        Sheet2.Cells(lrow, 6).Value = Sheet1.Range("c6")
        Sheet2.Cells(lrow, 7).Value = Sheet1.Range("d6")
        Sheet2.Cells(lrow, 8).Value = Sheet1.Range("e6")
        Sheet2.Cells(lrow, 9).Value = Sheet1.Range("c7")
        Sheet2.Cells(lrow, 10).Value = Sheet1.Range("d7")
        Sheet2.Cells(lrow, 11).Value = Sheet1.Range("e7")
        Sheet2.Cells(lrow, 12).Value = Sheet1.Range("c8")
        Sheet2.Cells(lrow, 13).Value = Sheet1.Range("d8")
        Sheet2.Cells(lrow, 14).Value = Sheet1.Range("e8")
        Sheet2.Cells(lrow, 15).Value = Sheet1.Range("c9")
        Sheet2.Cells(lrow, 16).Value = Sheet1.Range("d9")
        Sheet2.Cells(lrow, 17).Value = Sheet1.Range("e9")
        Sheet2.Cells(lrow, 18).Value = Sheet1.Range("c10")
        Sheet2.Cells(lrow, 19).Value = Sheet1.Range("d10")
        Sheet2.Cells(lrow, 20).Value = Sheet1.Range("e10")
        Sheet2.Cells(lrow, 21).Value = Sheet1.Range("c11")
        Sheet2.Cells(lrow, 22).Value = Sheet1.Range("d11")
        Sheet2.Cells(lrow, 23).Value = Sheet1.Range("e11")
        Sheet2.Cells(lrow, 24).Value = Sheet1.Range("c12")
        Sheet2.Cells(lrow, 25).Value = Sheet1.Range("d12")
        Sheet2.Cells(lrow, 26).Value = Sheet1.Range("e12")
        Sheet2.Cells(lrow, 27).Value = Sheet1.Range("c13")
        Sheet2.Cells(lrow, 28).Value = Sheet1.Range("d13")
        Sheet2.Cells(lrow, 29).Value = Sheet1.Range("e13")
        Sheet2.Cells(lrow, 30).Value = Sheet1.Range("c14")
        Sheet2.Cells(lrow, 31).Value = Sheet1.Range("d14")
        Sheet2.Cells(lrow, 32).Value = Sheet1.Range("e14")
        For i = 5 To 14
            Sheet1.Cells(i, 3) = ""
            Sheet1.Cells(i, 4) = ""
            Sheet1.Cells(i, 5) = ""
        Next i
        Range("g3") = Range("g3") + 1
    End If
End Sub
Sub loads()
Dim fr As Integer
On Error GoTo Error_handler:
fr = Application.WorksheetFunction.Match(Sheet1.Range("g3"), Sheet2.Range("a:a"), False)
    Sheet1.Range("c3") = Sheet2.Cells(fr, 2)
    Sheet1.Range("c5") = Sheet2.Cells(fr, 3)
    Sheet1.Range("d5") = Sheet2.Cells(fr, 4)
    Sheet1.Range("e5") = Sheet2.Cells(fr, 5)
    Sheet1.Range("c6") = Sheet2.Cells(fr, 6)
    Sheet1.Range("d6") = Sheet2.Cells(fr, 7)
    Sheet1.Range("e6") = Sheet2.Cells(fr, 8)
    Sheet1.Range("c7") = Sheet2.Cells(fr, 9)
    Sheet1.Range("d7") = Sheet2.Cells(fr, 10)
    Sheet1.Range("e7") = Sheet2.Cells(fr, 11)
    Sheet1.Range("c8") = Sheet2.Cells(fr, 12)
    Sheet1.Range("d8") = Sheet2.Cells(fr, 13)
    Sheet1.Range("e8") = Sheet2.Cells(fr, 14)
    Sheet1.Range("c9") = Sheet2.Cells(fr, 15)
    Sheet1.Range("d9") = Sheet2.Cells(fr, 16)
    Sheet1.Range("e9") = Sheet2.Cells(fr, 17)
    Sheet1.Range("c10") = Sheet2.Cells(fr, 18)
    Sheet1.Range("d10") = Sheet2.Cells(fr, 19)
    Sheet1.Range("e10") = Sheet2.Cells(fr, 20)
    Sheet1.Range("c11") = Sheet2.Cells(fr, 21)
    Sheet1.Range("d11") = Sheet2.Cells(fr, 22)
    Sheet1.Range("e11") = Sheet2.Cells(fr, 23)
    Sheet1.Range("c12") = Sheet2.Cells(fr, 24)
    Sheet1.Range("d12") = Sheet2.Cells(fr, 25)
    Sheet1.Range("e12") = Sheet2.Cells(fr, 26)
    Sheet1.Range("c13") = Sheet2.Cells(fr, 27)
    Sheet1.Range("d13") = Sheet2.Cells(fr, 28)
    Sheet1.Range("e13") = Sheet2.Cells(fr, 29)
    Sheet1.Range("c14") = Sheet2.Cells(fr, 30)
    Sheet1.Range("d14") = Sheet2.Cells(fr, 31)
    Sheet1.Range("e14") = Sheet2.Cells(fr, 32)
    Exit Sub
Error_handler:
    Sheet1.Range("c3") = ""
    Sheet1.Range("c5") = ""
    Sheet1.Range("d5") = ""
    Sheet1.Range("e5") = ""
    Sheet1.Range("c6") = ""
    Sheet1.Range("d6") = ""
    Sheet1.Range("e6") = ""
    Sheet1.Range("c7") = ""
    Sheet1.Range("d7") = ""
    Sheet1.Range("e7") = ""
    Sheet1.Range("c8") = ""
    Sheet1.Range("d8") = ""
    Sheet1.Range("e8") = ""
    Sheet1.Range("c9") = ""
    Sheet1.Range("d9") = ""
    Sheet1.Range("e9") = ""
    Sheet1.Range("c10") = ""
    Sheet1.Range("d10") = ""
    Sheet1.Range("e10") = ""
    Sheet1.Range("c11") = ""
    Sheet1.Range("d11") = ""
    Sheet1.Range("e11") = ""
    Sheet1.Range("c12") = ""
    Sheet1.Range("d12") = ""
    Sheet1.Range("e12") = ""
    Sheet1.Range("c13") = ""
    Sheet1.Range("d13") = ""
    Sheet1.Range("e13") = ""
    Sheet1.Range("c14") = ""
    Sheet1.Range("d14") = ""
    Sheet1.Range("e14") = ""
    MsgBox ("in factor mojood nemibashad")
End Sub 

فایل ضمیمه گردید