أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





الترحيل من اليوزرفورم الى شيت الاكسل

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


موضوع مغلق


03-04-2021 12:25 صباحا
noureddine70
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2019
رقم العضوية : 11894
المشاركات : 73
الدولة : الجزائر
الجنس : ذكر
تاريخ الميلاد : 6-12-1970
يتابعهم : 7
يتابعونه : 0
قوة السمعة : 103
 offline 

السلام عليكم و رحمة الله و بركاته                     الترحيل الى شيت الاكسل عن طريق عمودين
انا عندي كود الترحيل الى شيت الاكسل بشرط اذا وجد قيمة Textbox1 في العمود A في شيت الاكسل لا يرحل و ان لم يجدها  يرحل و هذا هو الكود الذي استعمله
if ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Find(TextBox1.Value) Is Nothing Then

و المطلوب منكم كود بحيث  اذا وجد قيمة Textbox1 في العمود A و قيمة Textbox2 في العمود B في نفس السطر لا يرحل اما اذا وجد القيمتين مختلفتين و كذا اذا وجد قيمة TextBox1  و لم يجد  قيمة TextBox2  يرحل 
بارك الله فيكم و جزاكم الله خيرا
Posting to an Excel sheet by means of two columns
 
 
if ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Find(TextBox1.Value) Is Nothing Then
 


أفضل إجابة مقدمة من salim وهي:
وهل على من يريد المساعدة ان ينشأ ملفاً يحتوي على ما تريد ؟؟؟
الكود

Option Explicit

  Private Sub But_Check_Click()
 If Me.TextBox1 = "" Or Me.TextBox1 = "" Then Exit Sub
 
 Dim Ro%, Sh As Worksheet, i%
 Dim Bol As Boolean
 
 Set Sh = Sheets("Sheet1")
 Ro = Sh.Cells(Rows.Count, 1).End(3).Row
 If Ro = 1 Then
  Ro = 2
  Sh.Cells(Ro, 1) = Me.TextBox1
  Sh.Cells(Ro, 2) = Me.TextBox2
  Exit Sub
 End If
  i = 2
  Do Until i = Ro + 1
      If UCase(Me.TextBox1) & "*" & UCase(Me.TextBox2) = _
       UCase(Sh.Cells(i, 1)) & "*" & UCase(Sh.Cells(i, 2)) Then
       Bol = True
       MsgBox "This Values are Already Exsit" & Chr(10) & _
       "In: " & Sh.Cells(i, 1).Resize(, 2).Address
        Exit Sub
      End If
     i = i + 1
   Loop

  If Not Bol Then
   Sh.Cells(Ro + 1, 1) = Me.TextBox1
   Sh.Cells(Ro + 1, 2) = Me.TextBox2
  End If
 End Sub

الملف مرفق
عرض الإجابة




03-04-2021 06:37 صباحا
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif الترحيل من اليوزرفورم الى شيت الاكسل
وهل على من يريد المساعدة ان ينشأ ملفاً يحتوي على ما تريد ؟؟؟
الكود

Option Explicit

  Private Sub But_Check_Click()
 If Me.TextBox1 = "" Or Me.TextBox1 = "" Then Exit Sub
 
 Dim Ro%, Sh As Worksheet, i%
 Dim Bol As Boolean
 
 Set Sh = Sheets("Sheet1")
 Ro = Sh.Cells(Rows.Count, 1).End(3).Row
 If Ro = 1 Then
  Ro = 2
  Sh.Cells(Ro, 1) = Me.TextBox1
  Sh.Cells(Ro, 2) = Me.TextBox2
  Exit Sub
 End If
  i = 2
  Do Until i = Ro + 1
      If UCase(Me.TextBox1) & "*" & UCase(Me.TextBox2) = _
       UCase(Sh.Cells(i, 1)) & "*" & UCase(Sh.Cells(i, 2)) Then
       Bol = True
       MsgBox "This Values are Already Exsit" & Chr(10) & _
       "In: " & Sh.Cells(i, 1).Resize(, 2).Address
        Exit Sub
      End If
     i = i + 1
   Loop

  If Not Bol Then
   Sh.Cells(Ro + 1, 1) = Me.TextBox1
   Sh.Cells(Ro + 1, 2) = Me.TextBox2
  End If
 End Sub

الملف مرفق
 
 
  Double_Text.xlsm   تحميل xlsm مرات التحميل :(14)
الحجم :(27.545) KB




الكلمات الدلالية
الترحيل ، اليوزرفورم ، الاكسل ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 01:30 صباحا