اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

ثبات مؤشر الكتابة


الردود الموصى بها

السلام عليكم

 

أساتذتنا الكرام كيف اجعل مؤشر الكتابة ثابت في TEXTBOX2 بعد عملية الترحيل اي بعد عملية الترحيل يرجع المؤشر ل TEXTBOX2

 Sub DOKOL1()
 

Dim lr As Long
Dim dat As Date
dat = UserForm2.TextBox1
cou = Application.WorksheetFunction.CountIfs(range("A2:A100000"), UserForm2.TextBox1, range("b2:b100000"), UserForm2.TextBox2)
If cou = 1 Then
lr = MATCHAlsqr(Sheet2.range("A2:b10000"), dat, 1, UserForm2.TextBox2, 2, 1) + 1
Else
lr = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
If Sheet2.Cells(lr, 5) <> "" Then Call KOROG11: Exit Sub

Sheet2.Cells(lr, 1) = Format(UserForm2.TextBox1.Value, "yyyy/mm/dd")
Sheet2.Cells(lr, 2) = UserForm2.TextBox2.Value
Sheet2.Cells(lr, 3) = Sheet1.Cells(Application.WorksheetFunction.Match(UserForm2.TextBox2.Value + 0, Sheet1.range("a:a"), 0), 2)
Sheet2.Cells(lr, 4) = UserForm2.TextBox3.Value
Sheet2.Cells(lr, 5) = Format(Now, "hh:mm")
Sheet2.Cells(lr, 9).FormulaR1C1 = "=IF(NOT(OR(COUNTA(RC[-4]:RC[-3])=1,COUNTA(RC[-2]:RC[-1])=1)),IF(RC[-3]<RC[-4],RC[-3]+1-RC[-4],RC[-3]-RC[-4])+IF(RC[-1]<RC[-2],RC[-1]+1-RC[-2],RC[-1]-RC[-2]),"""")"
Sheet2.Cells(lr, 10).FormulaR1C1 = "=VLOOKUP(RC[-8],Sheet1!R2C1:R10000C4,4,0)"
Sheet2.Cells(lr, 11).FormulaR1C1 = "=IF(RC[-2]="""","""",IF((RC[-1]/24)<RC[-2],ABS(RC[-2]-(RC[-1]/24)),ABS(RC[-2]-(RC[-1]/24))))"
Sheet2.Cells(lr, 12).FormulaR1C1 = "=IF(RC[-3]="""","""",IF((RC[-2]/24)<RC[-3],RC[-3]-(RC[-2]/24),(RC[-2]/24)-RC[-3]))"
Sheet2.range(Cells(lr, 9), Cells(lr, 12)).Value = Sheet2.range(Cells(lr, 9), Cells(lr, 12)).Value


UserForm2.TextBox2.Value = ""

Call WindowsMediaPlayer1_OpenStateChange


End Sub

 

تم تعديل بواسطه أبو عبد الملك السوفي
رابط هذا التعليق
شارك

جرب الكود بهذه الطريقة ولو حدث خطأ الرجاء تحميل الملف لكي يتم العمل عليه

 Sub DOKOL1()
 

Dim lr As Long
Dim dat As Date
dat = UserForm2.TextBox1
cou = Application.WorksheetFunction.CountIfs(Range("A2:A100000"), UserForm2.TextBox1, Range("b2:b100000"), UserForm2.TextBox2)
If cou = 1 Then
lr = MATCHAlsqr(Sheet2.Range("A2:b10000"), dat, 1, UserForm2.TextBox2, 2, 1) + 1
Else
lr = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
If Sheet2.Cells(lr, 5) <> "" Then Call KOROG11: GoTo l

Sheet2.Cells(lr, 1) = Format(UserForm2.TextBox1.Value, "yyyy/mm/dd")
Sheet2.Cells(lr, 2) = UserForm2.TextBox2.Value
Sheet2.Cells(lr, 3) = Sheet1.Cells(Application.WorksheetFunction.Match(UserForm2.TextBox2.Value + 0, Sheet1.Range("a:a"), 0), 2)
Sheet2.Cells(lr, 4) = UserForm2.TextBox3.Value
Sheet2.Cells(lr, 5) = Format(Now, "hh:mm")
Sheet2.Cells(lr, 9).FormulaR1C1 = "=IF(NOT(OR(COUNTA(RC[-4]:RC[-3])=1,COUNTA(RC[-2]:RC[-1])=1)),IF(RC[-3]<RC[-4],RC[-3]+1-RC[-4],RC[-3]-RC[-4])+IF(RC[-1]<RC[-2],RC[-1]+1-RC[-2],RC[-1]-RC[-2]),"""")"
Sheet2.Cells(lr, 10).FormulaR1C1 = "=VLOOKUP(RC[-8],Sheet1!R2C1:R10000C4,4,0)"
Sheet2.Cells(lr, 11).FormulaR1C1 = "=IF(RC[-2]="""","""",IF((RC[-1]/24)<RC[-2],ABS(RC[-2]-(RC[-1]/24)),ABS(RC[-2]-(RC[-1]/24))))"
Sheet2.Cells(lr, 12).FormulaR1C1 = "=IF(RC[-3]="""","""",IF((RC[-2]/24)<RC[-3],RC[-3]-(RC[-2]/24),(RC[-2]/24)-RC[-3]))"
Sheet2.Range(Cells(lr, 9), Cells(lr, 12)).Value = Sheet2.Range(Cells(lr, 9), Cells(lr, 12)).Value


UserForm2.TextBox2.Value = ""

Call WindowsMediaPlayer1_OpenStateChange
l:
UserForm2.TextBox2.SetFocus
End Sub

 

رابط هذا التعليق
شارك

5 دقائق مضت, عبدالسلام ابوالعوافي said:

جرب الكود بهذه الطريقة ولو حدث خطأ الرجاء تحميل الملف لكي يتم العمل عليه


 Sub DOKOL1()
 

Dim lr As Long
Dim dat As Date
dat = UserForm2.TextBox1
cou = Application.WorksheetFunction.CountIfs(Range("A2:A100000"), UserForm2.TextBox1, Range("b2:b100000"), UserForm2.TextBox2)
If cou = 1 Then
lr = MATCHAlsqr(Sheet2.Range("A2:b10000"), dat, 1, UserForm2.TextBox2, 2, 1) + 1
Else
lr = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
If Sheet2.Cells(lr, 5) <> "" Then Call KOROG11: GoTo l

Sheet2.Cells(lr, 1) = Format(UserForm2.TextBox1.Value, "yyyy/mm/dd")
Sheet2.Cells(lr, 2) = UserForm2.TextBox2.Value
Sheet2.Cells(lr, 3) = Sheet1.Cells(Application.WorksheetFunction.Match(UserForm2.TextBox2.Value + 0, Sheet1.Range("a:a"), 0), 2)
Sheet2.Cells(lr, 4) = UserForm2.TextBox3.Value
Sheet2.Cells(lr, 5) = Format(Now, "hh:mm")
Sheet2.Cells(lr, 9).FormulaR1C1 = "=IF(NOT(OR(COUNTA(RC[-4]:RC[-3])=1,COUNTA(RC[-2]:RC[-1])=1)),IF(RC[-3]<RC[-4],RC[-3]+1-RC[-4],RC[-3]-RC[-4])+IF(RC[-1]<RC[-2],RC[-1]+1-RC[-2],RC[-1]-RC[-2]),"""")"
Sheet2.Cells(lr, 10).FormulaR1C1 = "=VLOOKUP(RC[-8],Sheet1!R2C1:R10000C4,4,0)"
Sheet2.Cells(lr, 11).FormulaR1C1 = "=IF(RC[-2]="""","""",IF((RC[-1]/24)<RC[-2],ABS(RC[-2]-(RC[-1]/24)),ABS(RC[-2]-(RC[-1]/24))))"
Sheet2.Cells(lr, 12).FormulaR1C1 = "=IF(RC[-3]="""","""",IF((RC[-2]/24)<RC[-3],RC[-3]-(RC[-2]/24),(RC[-2]/24)-RC[-3]))"
Sheet2.Range(Cells(lr, 9), Cells(lr, 12)).Value = Sheet2.Range(Cells(lr, 9), Cells(lr, 12)).Value


UserForm2.TextBox2.Value = ""

Call WindowsMediaPlayer1_OpenStateChange
l:
UserForm2.TextBox2.SetFocus
End Sub

 

للعلم استاذ يوجد هذا الكود في حدث التكس بوكس2

 

 

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If TextBox2 = "" Then Exit Sub
 r = Application.WorksheetFunction.CountIf(Sheet1.range("a:a"), TextBox2)
If r = 0 Then: TextBox2 = "": Exit Sub
ComboBox1.Value = Sheet1.Cells(Application.WorksheetFunction.Match(TextBox2.Value + 0, Sheet1.range("a:a"), 0), 2)
 TextBox3.Value = Sheet1.Cells(Application.WorksheetFunction.Match(TextBox2.Value + 0, Sheet1.range("a:a"), 0), 5)
   Call TextBox2_Change
   
   End Sub

 

اي ان الكود يتم تنقيذه عند الخروج من التكس بوكس2

رابط هذا التعليق
شارك

طريقة ارجاع المؤشر الى التكست بوكس هي  setfocus ويجب ان تكون في اخر الاجراء .. يعني لو ان الاكواد متداخلة باكثر من اجراء يجب تتبع كل التفريعات للاجراءات وتكون نهايتها بالـ setfocus

ممكن يكون صعب فهم كلامي بدون مثال كصعوبة فهم اكوادك بدون رفع الملف

  • Like 1
رابط هذا التعليق
شارك

الحمد لله تم حل المشكل بتكوين كود لغلق الفوروم واعادة فتحه بعد تنفيذ عملية الترحيل ...شكرا لكم جميعا جزاكم الله خيرا

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information