ممكن مساعده فى كود الترحيل لشيتين وفقا لشرط

[الصفتى]

' ليدجر - حجوزات ترحيل
Dim answer As Integer
answer = MsgBox("ترغب فى ادخال هذه البيانات", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation")
If answer = vbYes Then


If Txt3 <> "" Then
 

Dim rng1 As Range
Dim str_search As String
str_search = Txt3.Value

Set rng1 = Sheets("ليدجر").Range("E:E").Find(str_search, , xlValues, xlWhole)

Application.ScreenUpdating = False
Dim row_number As Long
row_number = rng1.Row
Dim lastcolumn As Long
lastcolumn = IIf(Sheets("ليدجر").Range("lu" & row_number) = "", 333, Sheets("ليدجر").Range("lu" & row_number).End(xlToRight).Column + 1)
Sheets("ليدجر").Cells(row_number, lastcolumn).Value = C3.Value
Sheets("ليدجر").Cells(row_number, lastcolumn + 1).Value = CDate(C4)
Sheets("ليدجر").Cells(row_number, lastcolumn + 2).Value = C5.Value
Sheets("ليدجر").Cells(row_number, lastcolumn + 3).Value = C6.Value
Sheets("ليدجر").Cells(row_number, lastcolumn + 4).Value = C7.Value

'Sheets("ليدجر").Select
Cells(row_number, lastcolumn).Select

Dim lastrow As Long
lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row
lastrow = lastrow + 1

With ThisWorkbook.Sheets("حجوزات")
.Range("H" & lastrow).Value = Txt50.Value
.Range("I" & lastrow).Value = Txt3.Value
.Range("D" & lastrow).Value = TXT1.Value
.Range("G" & lastrow).Value = CDate(TXT2)
.Range("F" & lastrow).Value = Txt8.Value
.Range("K" & lastrow).Value = Txt18.Value
.Range("M" & lastrow).Value = Txt28.Value
.Range("N" & lastrow).Value = Txt31.Value



'كود مسح البيانات
Me.Txt50.Value = ""
Me.Txt3.Value = ""
Me.TXT1.Value = ""
Me.TXT2.Value = ""
Me.Txt8.Value = ""
Me.Txt18.Value = ""
Me.Txt28.Value = ""
Me.Txt31.Value = ""

End With
End If
End If
 
MsgBox "تم الترحيل بنجاح"

If Not rng1 Is Nothing Then
Dim lastrow As Long
lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row
lastrow = lastrow + 1

With ThisWorkbook.Sheets("حجوزات")
.Range("H" & lastrow).Value = Txt50.Value
.Range("I" & lastrow).Value = Txt3.Value
.Range("D" & lastrow).Value = TXT1.Value
.Range("G" & lastrow).Value = CDate(TXT2)
.Range("F" & lastrow).Value = Txt8.Value
.Range("K" & lastrow).Value = Txt18.Value
.Range("M" & lastrow).Value = Txt28.Value
.Range("N" & lastrow).Value = Txt31.Value

'كود مسح البيانات
Me.Txt50.Value = ""
Me.Txt3.Value = ""
Me.TXT1.Value = ""
Me.TXT2.Value = ""
Me.Txt8.Value = ""
Me.Txt18.Value = ""
Me.Txt28.Value = ""
Me.Txt31.Value = ""

Application.ScreenUpdating = True

End With
End If

MsgBox "تم الترحيل بنجاح"
  

عايز لو (txt3<>"") يرحل وفقا للكودين  للشيتين و ده بيحصل فعلا اللى محتاجه انه لو (txt3="") يرحل الكود التانى فقط لشيت الحجوزات

[أ / محمد صالح]

إن شاء الله يكون هذا هو المطلوب

تم إخراج الترحيل لشيت حجوزات من شرط عدم فراغ txt3

' ليدجر - حجوزات ترحيل
Application.ScreenUpdating = FALSE
Dim answer          As Integer
answer = MsgBox("ترغب فى ادخال هذه البيانات", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation")
If answer = vbYes Then    
    If Txt3 <> "" Then       
        Dim rng1    As Range
        Dim str_search As String
        str_search = Txt3.Value       
        Set rng1 = Sheets("ليدجر").Range("E:E").Find(str_search, , xlValues, xlWhole)   
        Dim row_number As Long
        row_number = rng1.Row
        Dim lastcolumn As Long
        lastcolumn = IIf(Sheets("ليدجر").Range("lu" & row_number) = "", 333, Sheets("ليدجر").Range("lu" & row_number).End(xlToRight).Column + 1)
        Sheets("ليدجر").Cells(row_number, lastcolumn).Value = C3.Value
        Sheets("ليدجر").Cells(row_number, lastcolumn + 1).Value = CDate(C4)
        Sheets("ليدجر").Cells(row_number, lastcolumn + 2).Value = C5.Value
        Sheets("ليدجر").Cells(row_number, lastcolumn + 3).Value = C6.Value
        Sheets("ليدجر").Cells(row_number, lastcolumn + 4).Value = C7.Value
        'Sheets("ليدجر").Select
        Cells(row_number, lastcolumn).Select
    End If        
        Dim lastrow As Long
        lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row
        lastrow = lastrow + 1
        With ThisWorkbook.Sheets("حجوزات")
            .Range("H" & lastrow).Value = Txt50.Value
            .Range("I" & lastrow).Value = Txt3.Value
            .Range("D" & lastrow).Value = TXT1.Value
            .Range("G" & lastrow).Value = CDate(TXT2)
            .Range("F" & lastrow).Value = Txt8.Value
            .Range("K" & lastrow).Value = Txt18.Value
            .Range("M" & lastrow).Value = Txt28.Value
            .Range("N" & lastrow).Value = Txt31.Value
            'كود مسح البيانات
            Me.Txt50.Value = ""
            Me.Txt3.Value = ""
            Me.TXT1.Value = ""
            Me.TXT2.Value = ""
            Me.Txt8.Value = ""
            Me.Txt18.Value = ""
            Me.Txt28.Value = ""
            Me.Txt31.Value = ""
        End With
End If
Application.ScreenUpdating = True
MsgBox "تم الترحيل بنجاح"

بالتوفيق

[lionheart]

    If Txt3 <> "" Then
        ---------
        ---------
    Else
        GoTo NXT
    End If
NXT:
    Dim lastrow As Long

 

[الصفتى]

شكرا استاذ محمد

الكود يعمل بنجاح

جزاك الله خيرا

[أ / محمد صالح]

جميعا بإذن الله 

نفعنا الله جميعا بما علمنا وعلمنا ما ينفعنا