ترحيل من خلال يوزرفورم

ترحيل لعدة شيتات من خلال يوزرفورم

أحيانا نرغب فى ترحيل بيانات معينة مثل ( البيانات التى تكون فى أعلى الصفحات ) ونظرا لكونها تعتبر بيانات رئيسية يتم تكرارها فى عدة شيتات _( أوراق العمل )_ ونرغب فى ادخال تلك البيانات دفعة واحدة من خلال الضغط على زر توفيرا للوقت والجهد

يمكننا تنفيذ ذلك الأمر من خلال يوزرفورم بإستخدام كود برمجى اتسهيل تلك المهمة الروتينية المتكررة فى عدة أوراق عمل

فعلى سبيل المثال

لدينا بيانات كالتالي ونرغب فى إدخالها دفعة واحدة فى عدة صفحات

1. اسم الشركة
2. رقم السجل التجاري
3. عنوان الشركة
4. رقم البطاقة الضريبية
5. وكذلك اللوجو الخاص بالشركة

ونريد ادخالها أو ترحيلها من اليوزرفورم إلى عدد ( 7 ) شيتات _( 7 أوراق عمل )

نتطرق إلى الشفرات البرمجية المستخدمة مع بعض التوضيحات الخاصة باليوزرفورم

أولا خطوات التصميم لليوزر

1. اضغط على Alt + F11 للدخول لمحرر الأكواد
2. اضغط كليك يمين على يسار نافذة المحرر
3. اختر ادراج Userform
4. ثم ادرج من أداة Toolbox من شريط المهام أعلى شاشة المحرر الأدوات المستخدمة

ثانيا الصناديق المستخدمة

1. عدد ( 9 ) Label
2. عدد ( 4 ) TextBox
3. عدد ( 1 ) Image

توضيحات لبعض الصناديق

1. Label1  المدون عليه البيانات الرئيسية للمنشأة
2. من Label2 : Label5 بيانات المنشأة
3. Label6 خاص بحفظ البيانات
4. Label7 خاص بمسح بيانات اليوزرفورم
5. Label8 خاص بإغلاق اليوزرفورم
6. Label9 خاص بإدراج الصورة داخل صندوق Image1

كود حفظ البيانات داخل Label6 بحدث Click أى عند النقر عليه يتم تنفيذ الشفرة ( ترحيلها من اليوزرفورم إلى عدد الشيتات المطلوبة والمشار اليها بالشفرة بأسماء المتغيرات السبعة والتى تم تخصيص كل متغير منهم لكل شيت من الشيتات السبعه )

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com

Private Sub Label6_Click()
Dim wM, wZ, wJ, wA, wB, wC, wD As Worksheet

Set wM = Sheets("sheet1")
Set wZ = Sheets("sheet2")
Set wJ = Sheets("sheet3")
Set wA = Sheets("sheet4")
Set wB = Sheets("sheet5")
Set wC = Sheets("sheet6")
Set wD = Sheets("sheet7")
    
wM.Cells(2, 2).Value = Me.TextBox1.Value
wM.Cells(3, 2).Value = Me.TextBox2.Value
wM.Cells(4, 2).Value = Me.TextBox3.Value
wM.Cells(5, 2).Value = Me.TextBox4.Value
wM.OLEObjects("ImageA").Object.Picture = Image1.Picture

wZ.Cells(2, 2).Value = Me.TextBox1.Value
wZ.Cells(3, 2).Value = Me.TextBox2.Value
wZ.Cells(4, 2).Value = Me.TextBox3.Value
wZ.Cells(5, 2).Value = Me.TextBox4.Value
wZ.OLEObjects("ImageB").Object.Picture = Image1.Picture

wJ.Cells(2, 2).Value = Me.TextBox1.Value
wJ.Cells(3, 2).Value = Me.TextBox2.Value
wJ.Cells(4, 2).Value = Me.TextBox3.Value
wJ.Cells(5, 2).Value = Me.TextBox4.Value
wJ.OLEObjects("ImageC").Object.Picture = Image1.Picture

wA.Cells(2, 2).Value = Me.TextBox1.Value
wA.Cells(3, 2).Value = Me.TextBox2.Value
wA.Cells(4, 2).Value = Me.TextBox3.Value
wA.Cells(5, 2).Value = Me.TextBox4.Value
wA.OLEObjects("ImageD").Object.Picture = Image1.Picture

wB.Cells(2, 2).Value = Me.TextBox1.Value
wB.Cells(3, 2).Value = Me.TextBox2.Value
wB.Cells(4, 2).Value = Me.TextBox3.Value
wB.Cells(5, 2).Value = Me.TextBox4.Value
wB.OLEObjects("ImageE").Object.Picture = Image1.Picture

wC.Cells(2, 2).Value = Me.TextBox1.Value
wC.Cells(3, 2).Value = Me.TextBox2.Value
wC.Cells(4, 2).Value = Me.TextBox3.Value
wC.Cells(5, 2).Value = Me.TextBox4.Value
wC.OLEObjects("ImageF").Object.Picture = Image1.Picture

wD.Cells(2, 2).Value = Me.TextBox1.Value
wD.Cells(3, 2).Value = Me.TextBox2.Value
wD.Cells(4, 2).Value = Me.TextBox3.Value
wD.Cells(5, 2).Value = Me.TextBox4.Value
wD.OLEObjects("ImageG").Object.Picture = Image1.Picture

Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
Me.TextBox4.Value = ""

MsgBox ("تم الترحيل بنجاح")
End Sub

كود مسح البيانات بداخل حدث Click للـ Label7

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com

Private Sub Label7_Click()
Me.TextBox1.Text = ""
Me.TextBox2.Text = ""
Me.TextBox3.Text = ""
Me.TextBox4.Text = ""
End Sub

كود الإغلاق لليوزر فورم داخل حدث Click للـ Label8

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com

Private Sub Label8_Click()
Unload Me
End Sub

كود استدعاء الصورة ( لوجو المنشأة ) داخل حدث Click للـ Label9

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com

Private Sub Label9_Click()
  Dim strFileName As String
    
    strFileName = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False)
    
    If strFileName = "False" Then
        MsgBox "لم يتم اختيار صورة"
    Else
        Me.Image1.Picture = LoadPicture(strFileName)
        LastSelectedFilePath = strFileName
        Me.Repaint
    End If

End Sub

• تلميحات هامة

فى حالة الرغبة فى زيادة عدد الأوراق التى سيتم الترحيل إليها نقوم بإضافة متغير جديد كمثل السطر البرمجى التالي

Dim wM As Worksheet

فى حالة الرغبة فى زيادة عدد الأوراق التى سيتم الترحيل إليها نقوم بإضافة تخصيص جديد كمثل السطر البرمجى التالي

Set wM = Sheets("sheet1")

السطور البرمجية الخاصة بترحيل البيانات من اليوزرفورم إلى أوراق العمل كما بالسطر البرمجى التالي

wM.Cells(2, 2).Value = Me.TextBox1.Value

تم إضافة صندوق صورة بكل ورقة عمل مع تسميته باسم مختلف بكل ورقة لكى يتم ترحيل اللوجو أو الشعار من اليوزرفورم إليها

كما بالسطر البرمجى التالي

wM.OLEObjects("ImageA").Object.Picture = Image1.Picture

لتحميل الكود المستخدم داخل ملف نصى

Download ⇊