نقل البيانات من ملف يحتوي على شيتات الى ملف اخر في شيت واحد

[عبدالله صباح]

السلام عليكم

محتاج كود 

لنقل بيانات من ملف يحتوي على ثلاث شيتات الى ملف في شيت واحد دون تكرار

مع العلم بان ملف البودرة بياناته في ازدياد يوميا

البودرة.xlsm البرنامج.xlsm

[احمدزمان]

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

جرب هذا الموضوع

ان شاء الله تجد به ما تريد

https://www.officena.net/ib/topic/38355-مكتبة-الموقع-مُجمِع-البيانات-للاكسيل-excel-data-collector/

وهو للعلامه محمد طاهر

 

[احمدزمان]

[عبدالفتاح في بي اكسيل]

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

[عبدالله صباح]

السلام عليكم

ملف البودرة يحول لي كل يوم عن طريق الوتساب

احول الملف الوارد الى البرنامج الخاص بي

فأحتاج يوميا تحديث البيانات على ضوء ما ورد لي

 

 

[عبدالفتاح في بي اكسيل]

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

[عبدالله صباح]

السلام عليكم ... على اساس رقم المستند ... تسلم

 

 

 

[احمدزمان]

‏الاثنين‏، 5‏/7‏/2021م الموافق ‏26‏/11‏/1442هـ

 طريقة الاستخدام

يتم فتح الملفين : البرنامج و البودرة

من ملف البرنامج الذهاب الى ورقة TransPorter

 اضغط على خطوة 1

سوف يتم تحديث بيانات القوائم المنسدلة ببيانات جميع الملفات المفتوحة من اسم الملف و أسماء الأوراق في ككل ملف

ابدء بتعبئة البيانات في الجدول كامل

حدد أسماء الملفات المصدر و الوجهة و أسماء الأوراق المنقولة منها البيانات و اسم الرقة الهدف التي سوف توضع بها البيانات

ثم

اضغط زر ابدء نقل البيانات

يتم نقل البيانات من جميع الأوراق الى الورقة الحالية

 مع التحية

 الصورة للشاشة

 

 الاكواد المستخدمة

'عمل قائمة اسماء الملفات
Application.ScreenUpdating = False
WBK1 = ActiveWorkbook.Name
Set TS = Workbooks(WBK1).Sheets("TransPorter")
TS.Unprotect 'Password:=Range("PW")
TS.Range("A4:B99").ClearContents
R = 4
For WB = 1 To Workbooks.Count
BN = Workbooks(WB).Name
For Sh = 1 To Workbooks(BN).Sheets.Count
TS.Cells(R, 1) = BN
TS.Cells(R, 2) = Workbooks(BN).Sheets(Sh).Name
R = R + 1
Next Sh
R = R + 1
Next WB
'TS.Range("AB4").ClearContents
TS.Range("K3") = WBK1
[I3] = ""
[H6] = ""
[K6] = ""
Application.ScreenUpdating = True
'Application.Run "Data_TransPorter01_Clear"
'Application.Run "Protct"
ActiveSheet.EnableSelection = xlUnlockedCells

--

Dim WB1N, WB2N, WB3N, FDT, TDT, DTC, FC1, FC2, TC, TR
Dim TSH, SHN, CC, CC2, CC3
Dim RN1 As Range
If Sheets("TransPorter").Range("Q14") = False Then
QQ = Sheets("TransPorter").Range("Q15").Text
MsgBox QQ, vbMsgBoxRight, "أكمل البيانات المطلوبة"
Exit Sub
End If
'CreateObject("Wscript.shell").Popup "إنتظر قليلاً حتى الإنتهاء من معالجة البيانات", 0, "إنتظار !!!!", vbExclamation
WB1N = Range("I3").Text
WB2N = Range("K3").Text
WB3N = ActiveWorkbook.Name 'اسم ملف ورقة الأوامر
ORDERSHET = ActiveSheet.Name 'ورقة الإعدادات او الأوامر
TSN = Range("K4").Text
Set WB1 = Workbooks(WB1N) 'من ملف
Set WB2 = Workbooks(WB2N) 'الى ملف
Set WB3 = Workbooks(WB3N) 'ملف البيانات
Set OSH = WB3.Sheets(ORDERSHET)
Set TS = WB2.Sheets(TSN) 'الى الورقة
ActiveSheet.Unprotect ' Password:=Range("PW")
TS.Unprotect 'Password:=WB2.Range("PW")
FDT = OSH.Range("K6").Value 'من تاريخ
TDT = OSH.Range("K7").Value 'الى تاريخ
DTC = OSH.Range("M9").Text 'عمود التاريخ لملف مصدر البيانات
FC1 = OSH.Range("K8").Text 'من العمود
FC2 = OSH.Range("M8").Text 'و العمود
TC = OSH.Range("L10").Text 'العمود الوجهة
TR = Val(OSH.Range("L11")) 'الصف الوجهة
'
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
'
For SHN = 5 To 14
If OSH.Cells(SHN, 16) <> True Then GoTo 1
FSN = OSH.Cells(SHN, 8).Text
Set FS = WB1.Sheets(FSN)
ER = FS.UsedRange.Rows.Count + 11
For R = 1 To ER
QDT = FS.Range(DTC & R).Value
If QDT >= FDT And QDT <= TDT Then
CC2 = Val(Cells(1, FC1).Column) ' من عمود رقم
CC3 = Val(Cells(1, FC2).Column) ' الى عمود رقم
' التأكد من فراغ الصف الوجهة TR
7 For Each RN1 In Range(Cells(TR, CC2), Cells(TR, CC3))
    If RN1 <> "" Then
    TR = TR + 1
    GoTo 7
    End If
Next 'RN1
' نقل بيانات الصف
For CC = CC2 To CC3
TS.Cells(TR, CC) = FS.Cells(R, CC)
Next 'CC
TR = TR + 1
End If
Next 'R
1 Next 'SHN
OSH.Select
'Application.Run "Data_TransPorter01_Clear"
'Application.Run "protct"
Application.Calculation = xlAutomatic
Application.EnableEvents = True

 

البرنامج.xlsm

[عبدالله صباح]

جزيت خيرا .. ممنون .. تمام .. جربت العمل - جزاك الله عنا خير ,, فقط ممكن عند نقل البيانات يكون النقل الى الصف الثاني 

حاليا ينقل البيانات الى الصف 27   .. وكذلك - عند الضغط على زر النقل مرة ثانية لا ينقل الصفوف (البيانات) القديمة

فقط ينقل البيانات الجديدة على اساس رقم المستند حتى لا ىحدث تكرار ... فقط عندي حاليا هذه الملاحظات

 

 

 

[احمدزمان]

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

تم التعديل كما طلبت

في المرفق

 

البرنامج.xlsm

[عبدالله صباح]

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

اعزك الله اخي

جزيت خيرا

ملاحظة / وجدت نقص بنقل البيانات وبعد المتابعة

لاحظ عدم نقل بيانات شيت (بنزين)

فقط تم النقل من باقي الشيتات

 

 

[احمدزمان]

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

اسعد الله صباحكم بكل خير

حاول التالي

1

ادخل الى النموذج للنقل و من قائمة اسماء الاوراق اعد اختيار اسم الورقة ((بنزين))

2

تاكد ان اسم الورقة ((بنزين)) ليس به مسافة في آخر الاسم او بعد الاسم

 

و ان شاء الله تظبط

 

وفي انتظار ردك

 

[عبدالله صباح]

السلام عليكم .. ضبطت الاسماء والنتيجة نفسه

بعدين جربت أن يكون شيت الكاز ان اجعله اولا والبنزين ثانيا في ملف البودرة والبرنامج

كانت النتيجة نقل كل بيانات الشيت الثاني (بنزين) ونقل جزء من بيانات الشيت الاول (الكاز) .. والنفط لم ينقل أي بيانات

اعتقد بالمدى - اذ مجموع الصفوف في ملف البودرة  497 صف .. نقل فقط 318 صف في ملف البرنامج .. جزيت خيرا 

البرنامج.rar

[احمدزمان]

طيب اراجعه ان شاء الله

[عبدالله صباح]

جزيت خيرا

[احمدزمان]

اخي عبدالله كللامك مظبوط

يوجد خطاء تم تعديله

و كان الخطاء في الحلقة الدائرية للتاكد من خلو الخلية الهدف من اي بيانات للكتابه بها

سامحنا ... كل ابن آدم خطاء

البرنامج.xlsm

[عبدالله صباح]

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

وزادتكم الله شأنا وعلماً

رفعك الله ورضى الله عنك

تمام

العمل 100 %

[عبدالفتاح في بي اكسيل]

اخي  عبدالله  عندي  فضول    عندما  يتم  حدف  البيانات  المكررة    هل  يتم  تكرار  البيانات  في  كل  الاوراق   ام  في  نفس  الورقة  والحدف  يتم  على  اساس  اقدم  تاريخ  او  احدث  تاريخ  او  اقدم  ادخال  او  احدث  ادخال   ام  لا  يوجد  فرق  ؟

[عبدالله صباح]

السلام عليكم

عندما يرسل لي ملف البودرة - يرسل لي الكل

يرسل لي الملف كامل ابتدا من 1 / 6 وكل يوم يرسل الملف مع الاضافة - (كل يوم اضافة) وهكذا الى نهاية الشهر فاذا كان يوم الارسال 15 / 6 - يرسل لي الملف ابتداء من 1 / 6 

وعدم التكرار يكون على اساس رقم المستند

اذ رقم المستند لا يتكرر بكل الاوراق

 

 

[احمدزمان]

23 ساعات مضت, عبدالله صباح said:

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

وزادتكم الله شأنا وعلماً

رفعك الله ورضى الله عنك

تمام

العمل 100 %

اللهم آمين

انا و انت و جميع المسلمين

شكرا لك