اذهب الي المحتوي
أوفيسنا

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

yasser_w_2010

بواسطه yasser_w_2010
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

yasser_w_2010

yasser_w_2010

قام بنشر
قام بنشر

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

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

مثلا : اكتب كود رقم 1 و املاء بيانات الصف يرحل الى الشيت رقم 1 

       اكتب كود رقم 2 و املاء بيانات الصف يرحل الى الشيت رقم 2  وهاكذا

شاكر لكم جدا وجزيل الشكر لاستاذنا سليم

ترحيل بيانات.xlsm

احمدزمان

احمدزمان

قام بنشر
قام بنشر

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

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

Sub az_mokhtar()
'نقل البيانات
Dim FS As Worksheet, TS As Worksheet
Dim Q1, TR, FR, ER, SH
Set FS = Sheets(ActiveSheet.Name)
ER = 99
For FR = 12 To ER
Q1 = FS.Cells(FR, 3).Text
If Q1 = "" Then GoTo 9
For SH = 1 To ActiveWorkbook.Sheets.Count
If Sheets(SH).Name = Q1 Then
TR = Sheets(SH).[C65536].End(xlUp).Row + 1
For FC = 2 To 13
Sheets(SH).Cells(TR, FC) = FS.Cells(FR, FC)
Next FC
End If
Next SH
9
Next 'FR
''
End Sub

جرب المرفق مع التحية و التقدير

ترحيل بيانات.xlsm

  • Like 1
yasser_w_2010

yasser_w_2010

قام بنشر
  • الكاتب
قام بنشر

الف شكر اخي الكريم

عن التجربه كل لما اجي ارجل البيانات يتم تكرارها

وكذلك يتم الترحيل في شيتات رقم 1 و 2 و 3 من اول A9

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

 

شكرا لك استاذنا الكريم على تعبك ومجهودك

احمدزمان

احمدزمان

قام بنشر
قام بنشر

‏الاربعاء‏، 26‏/3‏/1442هـ الموافق ‏11‏/11‏/2020م

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

 

اخي الكريم

كلامك صحيح يوجد تكرار للترحيل

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

=====

لذلك

ان عدم تكرار البيانات في الترحيل هنا له 3 طرق

1

يتم مسح البيانات التي تم ترحيلها من داخل الكود

بحيث ان كل صف يتم ترحيله يتم مسح هذا الصف

2

يتم وضع رمز امام الصف الذي تم ترحيله

مثل : مرحل او تم او Dun او رقم او شرطة او أي شيء آخر

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

3

الطريقة الاصعب

يجب ان تحدد انت ماهو المتغير الذي لا يتكرر في بيانات أي صف

مثل : رقم السند – نوع السند – الاسم

ثم يتم تعديل الكود

بحيث عند ذهابه للورقة التي مطلوب الترحيل لها يبحث في العمود المحدد الذي به المتغير الذي لا يتكرر – فاذا وجد هذا المتغير جود لا يرحل البيانات و اذا لم يكن موجود يقوم بترحيل البيانات الى الورقة المطلوبة

مع التحيه

 

آمل ان تكون وضحة الفكرة

و عليك ان تحدد ماتريد

 

  • Like 1
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

 

1- حذرت كثيراً من الخلايا (او الصفوف ) المدمجة و لكن لا حياة لمن تنادي لذلك قمت بادراج صف فارغ (الصف رقم 11) 
   يرجى عدم المساس به  اي تركه فارغاً دون كنابة اي شيء فيه) والأفضل اخفاؤه

2-تم ادراج صفحة باسم "Modul"مخفية وتحتوي على الجدول الأساسي قارغاً (لنسخه في حال اضافة شيتات جديدة)
3- في حال اضافة اسم اي  شيت (في العامود  C من الضفخة Main ابتداء من الصف 12) غير موجودة في المصنف تتم      اضاقتها  اوتوماتيكياً
4-تنقل البيانات بدون تكرار كل بيان الى صفحته الحاصة مع الترقيم الأوتوماتيكي

الكود 

Option Explicit
Dim M As Worksheet
Dim Act_sh As Worksheet
Dim i%, Lr%, Max_ro%, rows_count%
'+++++++++++++++++++++++++++++++++++
Sub test()
Dim Bol  As Boolean
Lr = Sheets("Main").Cells(Rows.Count, 3).End(3).Row
If Lr < 12 Then Exit Sub
Application.DisplayAlerts = False
Sheets("Modul").Visible = True
For i = 12 To Lr
 Bol = WorksheetExists(Sheets("Main").Cells(i, 3))
 If Not Bol Then
  Sheets("Modul").Copy after:=Sheets(Sheets.Count)
  ActiveSheet.Name = Sheets("Main").Range("C" & i)
  
 End If
 Next
 Sheets("Modul").Visible = 2
 Sheets("Main").Select
 Application.DisplayAlerts = True

End Sub
'++++++++++++++++++++++++++++++++
Function WorksheetExists(ByVal WorksheetName As String) As Boolean
Dim Sht As Worksheet

    For Each Sht In ThisWorkbook.Worksheets
        If Application.Proper(Sht.Name) = Application.Proper(WorksheetName) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Sht
WorksheetExists = False
End Function
'"""""""""""""""""""""""""""""""
Sub Transfer_data()
test
Dim x
Set M = Sheets("Main")
If Lr < 12 Then Exit Sub
For i = 12 To Lr
  Set Act_sh = Sheets(M.Range("C" & i) & "")
  Max_ro = Act_sh.Cells(Rows.Count, 3).End(3).Row + 1
  If Max_ro < 12 Then Max_ro = 12
  Act_sh.Cells(Max_ro, 2).Resize(, 11).Value = _
  M.Cells(i, 2).Resize(, 11).Value
  '========================================
  Act_sh.Range("B12:L" & Max_ro).RemoveDuplicates _
   Columns:=Array(1, 2, 3, 4, 5, 6, _
   7, 8, 9, 10, 11), Header:=xlNo
rows_count = Act_sh.Range("B12").CurrentRegion.Rows.Count
   If Act_sh.Range("B12") <> vbNullString Then
    Act_sh.Range("A12").Resize(rows_count).Value = _
    Evaluate("Row(1:" & rows_count & ")")
  With Act_sh.Range("A12").CurrentRegion
  .Borders.LineStyle = 1
  .Font.Size = 14
  .Font.Bold = True
  .Columns(1).HorizontalAlignment = xlCenter
    End With
End If

Next
End Sub

الملف للتجربة وابداء الرأي

yasser_w.xlsm

  • Like 1
yasser_w_2010

yasser_w_2010

قام بنشر
  • الكاتب
قام بنشر (معدل)

اسف استاذ سليم لو بتاقل على حضرتك

ممكن يبقي الترحيل من عمود A الى العمود K فقط و ترك العمود L بدون ترحيل

وهل ممكن يتم الترحيل بنفس الاولوان و اتنسيق 

شكرا اوي اوي اخي الكريم استاذ سليم

yasser_w (3).xlsm

تم تعديل بواسطه yasser_w_2010
  • أفضل إجابة
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • أفضل إجابة
قام بنشر

تعدبل الكود 

Option Explicit
Dim M As Worksheet
Dim Act_sh As Worksheet
Dim i%, Lr%, Max_ro%, rows_count%
'+++++++++++++++++++++++++++++++++++
Sub test()
Dim Bol  As Boolean
Lr = Sheets("Main").Cells(Rows.Count, 3).End(3).Row
If Lr < 12 Then Exit Sub
Application.DisplayAlerts = False
Sheets("Modul").Visible = True
For i = 12 To Lr
 Bol = WorksheetExists(Sheets("Main").Cells(i, 3))
 If Not Bol Then
  Sheets("Modul").Copy after:=Sheets(Sheets.Count)
  ActiveSheet.Name = Sheets("Main").Range("C" & i)
  
 End If
 Next
 Sheets("Modul").Visible = 2
 Sheets("Main").Select
 Application.DisplayAlerts = True

End Sub
'++++++++++++++++++++++++++++++++
Function WorksheetExists(ByVal WorksheetName As String) As Boolean
Dim Sht As Worksheet

    For Each Sht In ThisWorkbook.Worksheets
        If Application.Proper(Sht.Name) = Application.Proper(WorksheetName) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Sht
WorksheetExists = False
End Function
'"""""""""""""""""""""""""""""""
Sub Transfer_data_New()
test
Dim x
Set M = Sheets("Main")
If Lr < 12 Then Exit Sub
For i = 12 To Lr
  Set Act_sh = Sheets(M.Range("C" & i) & "")
  Max_ro = Act_sh.Cells(Rows.Count, 3).End(3).Row + 1
  If Max_ro < 12 Then Max_ro = 12
  Act_sh.Cells(Max_ro, 2).Resize(, 11).Value = _
  M.Cells(i, 2).Resize(, 11).Value
  '========================================
  Act_sh.Range("B12:L" & Max_ro).RemoveDuplicates _
   Columns:=Array(1, 2, 3, 4, 5, 6, _
   7, 8, 9, 10, 11), Header:=xlNo
rows_count = Act_sh.Range("B12").CurrentRegion.Rows.Count
   If Act_sh.Range("B12") <> vbNullString Then
    Act_sh.Range("A12").Resize(rows_count).Value = _
    Evaluate("Row(1:" & rows_count & ")")
   M.Range("a12:k12").Copy
   With Act_sh.Range("A12").CurrentRegion
   .PasteSpecial (xlPasteFormats)
   .Columns(12).EntireColumn.Delete
  End With
End If

Next
End Sub

 

yasser_w Format.xlsm

  • Like 2
yasser_w_2010

yasser_w_2010

قام بنشر
  • الكاتب
قام بنشر

الف شكر استاذ سليم 

هوه نفس المطلوب بالضبط ربنا ما يحرمنا منك

طلب اخير

عند اضافة قيد اخر واعمل ادارج بيفضل يروح على كل الشيتات وبياخد وقت كبير نظرا لان ممكن اعمل اكثر من 6000 الف قيد لجميع الاصناف

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

واسف لو بطيل على حضرتك استاذنا الكبير

yasser_w Format (11).xlsm

زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept