ترحيل البيانات من نموذج ادخال رأسى الى صفحة منتظمة أفقى

[هانى محمد]

السلام عليكم أساتذتى وأحبائى الكرام أرجو من سيادتكم التكرم على مساعدتى بترحيل البيانات من نموذج ادخال بالمعادلات من صفحة Search الى صفحة Data بحيث يبدأ الترحيل بداية من الخلية A2 بصفحة Data بإسم الصنف الموجود بالخلية B1 من صفحة Search  وتم وضع شكل النتائج المطلوب ترحيلها الى صفحة Data وعند كل ترحيل يتم مسح اسم الصنف الموجود بالخلية B1 من صفحة Search وكمية الصنف بنفس الصفحة والموجود بالخلية A1

وأريد ان يتم ترحيل مبالغ البنود بناءاً على أسماء هذه الأصناف والبنود برؤوس الجدول الموجود بصفحة Data وهى الصفحة المرحل اليها

ملحوظة:البيانات التى يتم ترحيلها بجميع البنود متغيرة وليست ثابتة وقد تزيد البنود أو تقل وذلك حسب المواد الخام المنتجة لصنف أو سلعة معينة.. ولكم جزيل الشكر

تكلفة المخبوزات للحصول على الربح.xlsb

[محمد هشام.]

تفضل اخي

Sub Hany()
Dim a As Long
If Range("a1") = "" Then
MsgBox "المرجوا ادخال البيانات"
Else

 Application.ScreenUpdating = False
a = ThisWorkbook.Sheets("Data").Range("a1000000").End(xlUp).Row
a = a + 1
Feuil2.Select
Feuil3.Cells(a, 1) = Range("b1")
Feuil3.Cells(a, 2) = Range("a1")
Feuil3.Cells(a, 3) = Range("b3")
Feuil3.Cells(a, 4) = Range("b4")
Feuil3.Cells(a, 6) = Range("b5")
Feuil3.Cells(a, 7) = Range("b6")
Feuil3.Cells(a, 8) = Range("b7")
Feuil3.Cells(a, 10) = Range("b8")
Feuil3.Cells(a, 11) = Range("b9")
Feuil3.Cells(a, 12) = Range("b10")
Range("b1") = ""
Range("a1") = ""
Application.ScreenUpdating = True
End If
End Sub

تكلفة المخبوزات للحصول على الربح.xlsb

[هانى محمد]

بارك الله فيك أستاذ محمد وزادك الله من فضله كود بالطبع ممتاز , ولكنى من فضلك أريد ان يتم ترحيل مبالغ البنود بناءاً على أسماء هذه الأصناف والبنود برؤوس الجدول الموجود بصفحة Data وهى الصفحة المرحل اليها .أرجو الا أكون أزعجتكم وجزاك الله خير الثواب

تكلفة المخبوزات للحصول على الربح.xlsb

[ابراهيم الحداد]

السلام عليكم و رحمة الله

ربما تقصد هذا

Sub TrData()
Dim ws As Worksheet, sh As Worksheet
Dim LR As Long, x As Integer
Dim a As Double, Knd As String
Dim C As Range
Set sh = Sheets("Search")
Set ws = Sheets("Data")
a = sh.Range("A1"): Knd = sh.Range("B1")
LR = ws.Range("A" & Rows.Count).End(3).Row
For Each C In sh.Range("A3:A22")
On Error Resume Next
x = WorksheetFunction.Match(C, ws.Range("C1:X1"), 0)
If ws.Cells(1, x + 2) = C.Value Then
ws.Cells(LR + 1, 1) = Knd
ws.Cells(LR + 1, 2) = a
ws.Cells(LR + 1, x + 2) = C.Offset(0, 1)
End If
Next
End Sub

 

[هانى محمد]

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