اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

aboud424

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

 مشاركة

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

aboud424

aboud424

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

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

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

شكرا لكم مسبقا

Classeur2.rar

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

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

جرب هذا الكود 

Option Explicit
Sub give_data()

Dim i, r, k As Integer
Dim My_rg As Range
Dim My_Sh As Worksheet
Dim S1, S2 As String

 Application.ScreenUpdating = False
 For i = Sheets.Count To 2 Step -1
 Application.DisplayAlerts = False
 Sheets(i).Delete
 Next
 Application.DisplayAlerts = True
For i = 6 To 36
 If Main.Range("a" & i) = "" Then Exit For
On Error Resume Next
   S1 = Main.Range("a" & i).Value
   S2 = Sheets(S1).Name
   If S1 <> S2 Then
Sheets.Add After:=Sheets(Sheets.Count)
 With ActiveSheet
  .Name = Main.Range("a" & i)
     With .Range("a1:d1")
        .Value = Array("النوع", "الكميّة", "السعر", "قيمة الاستهلاك الشهري")
        .Interior.ColorIndex = 6
    End With
  End With
  On Error GoTo 0
  End If
  Next
  Main.Select
  For i = 6 To 36
  r = 2
    Set My_rg = Main.Range("a5:cx5")
    Set My_Sh = Sheets(Main.Range("a" & i) & "")
   For k = 2 To My_rg.Count
     If Main.Cells(i, k) <> "" Then
        With My_Sh
            .Cells(r, 1) = Main.Cells(i, k)
            .Cells(r, 2) = My_rg.Cells(k)
            .Cells(r, 3) = My_rg.Cells(k).Offset(-1, 0)
            .Cells(r, 4) = My_rg.Cells(k).Offset(-2, 0)
            .Columns.AutoFit
        End With
     r = r + 1
     End If
     Next
   Next
  Application.ScreenUpdating = True
End Sub

الملف مرفق

 

 

 

Classeur2 Salim.rar

  • Like 1
رابط هذا التعليق
شارك
aboud424

aboud424

قام بنشر
  • الكاتب
قام بنشر
في 08/06/2017 at 21:05, سليم حاصبيا said:

جرب هذا الكود 


Option Explicit
Sub give_data()

Dim i, r, k As Integer
Dim My_rg As Range
Dim My_Sh As Worksheet
Dim S1, S2 As String

 Application.ScreenUpdating = False
 For i = Sheets.Count To 2 Step -1
 Application.DisplayAlerts = False
 Sheets(i).Delete
 Next
 Application.DisplayAlerts = True
For i = 6 To 36
 If Main.Range("a" & i) = "" Then Exit For
On Error Resume Next
   S1 = Main.Range("a" & i).Value
   S2 = Sheets(S1).Name
   If S1 <> S2 Then
Sheets.Add After:=Sheets(Sheets.Count)
 With ActiveSheet
  .Name = Main.Range("a" & i)
     With .Range("a1:d1")
        .Value = Array("النوع", "الكميّة", "السعر", "قيمة الاستهلاك الشهري")
        .Interior.ColorIndex = 6
    End With
  End With
  On Error GoTo 0
  End If
  Next
  Main.Select
  For i = 6 To 36
  r = 2
    Set My_rg = Main.Range("a5:cx5")
    Set My_Sh = Sheets(Main.Range("a" & i) & "")
   For k = 2 To My_rg.Count
     If Main.Cells(i, k) <> "" Then
        With My_Sh
            .Cells(r, 1) = Main.Cells(i, k)
            .Cells(r, 2) = My_rg.Cells(k)
            .Cells(r, 3) = My_rg.Cells(k).Offset(-1, 0)
            .Cells(r, 4) = My_rg.Cells(k).Offset(-2, 0)
            .Columns.AutoFit
        End With
     r = r + 1
     End If
     Next
   Next
  Application.ScreenUpdating = True
End Sub

الملف مرفق

 

 

 

Classeur2 Salim.rar

اخي الكريم سليم اريد فاصل بين بين فطور الصباح والغداء والعشاء والمواد المشتركة لكي استغلهم في جدول اخر. 

 

  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

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

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

Option Explicit

Sub give_data1()

Dim i, r, k, My_row As Integer
Dim My_rg As Range
Dim My_Sh As Worksheet
Dim S1, S2 As String

 Application.ScreenUpdating = False
 For i = Sheets.Count To 2 Step -1
 Application.DisplayAlerts = False
 Sheets(i).Delete
 Next
 Application.DisplayAlerts = True
For i = 6 To 36
 If Main.Range("a" & i) = "" Then Exit For
On Error Resume Next
   S1 = Main.Range("a" & i).Value
   S2 = Sheets(S1).Name
   If S1 <> S2 Then
Sheets.Add After:=Sheets(Sheets.Count)
 With ActiveSheet
  .Name = Main.Range("a" & i)
     With .Range("a1:d1")
        .Value = Array("النوع", "الكميّة", "السعر", "قيمة الاستهلاك الشهري")
        .Interior.ColorIndex = 6
        .Range("e2") = "مواد تستهلك الفطور الصباح"
    End With
  End With
  On Error GoTo 0
  End If
  Next
  Main.Select
  For i = 6 To 36
  r = 2
    Set My_rg = Main.Range("a5:cx5")
    Set My_Sh = Sheets(Main.Range("a" & i) & "")
   For k = 2 To My_rg.Count
    If k = 10 Or k = 21 Or k = 67 Then
      My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row
      My_Sh.Rows(My_row + 1).Insert Shift:=xlDown: r = My_row + 2
      Select Case k
      Case 10
        My_Sh.Range("e" & My_row + 2) = "مواد تستهلك في العشاء فقط"
        Case 21
        My_Sh.Range("e" & My_row + 2) = " مواد تستهلك في الغداء فقط"
        Case 67
         My_Sh.Range("e" & My_row + 2) = "مواد مشتركة بين الغداء والعشاء"
      End Select
      
      End If
     If Main.Cells(i, k) <> "" Then
        With My_Sh
            .Cells(r, 1) = Main.Cells(i, k)
            .Cells(r, 2) = My_rg.Cells(k)
            .Cells(r, 3) = My_rg.Cells(k).Offset(-1, 0)
            .Cells(r, 4) = My_rg.Cells(k).Offset(-2, 0)
            .Columns.AutoFit
        End With
     r = r + 1
     End If
     Next
   Next
  Application.ScreenUpdating = True
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
aboud424

aboud424

قام بنشر
  • الكاتب
قام بنشر
18 ساعات مضت, سليم حاصبيا said:

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


Option Explicit

Sub give_data1()

Dim i, r, k, My_row As Integer
Dim My_rg As Range
Dim My_Sh As Worksheet
Dim S1, S2 As String

 Application.ScreenUpdating = False
 For i = Sheets.Count To 2 Step -1
 Application.DisplayAlerts = False
 Sheets(i).Delete
 Next
 Application.DisplayAlerts = True
For i = 6 To 36
 If Main.Range("a" & i) = "" Then Exit For
On Error Resume Next
   S1 = Main.Range("a" & i).Value
   S2 = Sheets(S1).Name
   If S1 <> S2 Then
Sheets.Add After:=Sheets(Sheets.Count)
 With ActiveSheet
  .Name = Main.Range("a" & i)
     With .Range("a1:d1")
        .Value = Array("النوع", "الكميّة", "السعر", "قيمة الاستهلاك الشهري")
        .Interior.ColorIndex = 6
        .Range("e2") = "مواد تستهلك الفطور الصباح"
    End With
  End With
  On Error GoTo 0
  End If
  Next
  Main.Select
  For i = 6 To 36
  r = 2
    Set My_rg = Main.Range("a5:cx5")
    Set My_Sh = Sheets(Main.Range("a" & i) & "")
   For k = 2 To My_rg.Count
    If k = 10 Or k = 21 Or k = 67 Then
      My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row
      My_Sh.Rows(My_row + 1).Insert Shift:=xlDown: r = My_row + 2
      Select Case k
      Case 10
        My_Sh.Range("e" & My_row + 2) = "مواد تستهلك في العشاء فقط"
        Case 21
        My_Sh.Range("e" & My_row + 2) = " مواد تستهلك في الغداء فقط"
        Case 67
         My_Sh.Range("e" & My_row + 2) = "مواد مشتركة بين الغداء والعشاء"
      End Select
      
      End If
     If Main.Cells(i, k) <> "" Then
        With My_Sh
            .Cells(r, 1) = Main.Cells(i, k)
            .Cells(r, 2) = My_rg.Cells(k)
            .Cells(r, 3) = My_rg.Cells(k).Offset(-1, 0)
            .Cells(r, 4) = My_rg.Cells(k).Offset(-2, 0)
            .Columns.AutoFit
        End With
     r = r + 1
     End If
     Next
   Next
  Application.ScreenUpdating = True
End Sub

 

السلاام عليكم ورحمة الله الاخ سليم لقد قمت ببعض التعديلات على المرفق. اريد تحويل المواد الى الفورم الموحد في كل الاوراق بشرط ان نظيف المواد المشتركة في الغداء والعشاء. 

تقبل تحياتي 

Classeur3.rar

رابط هذا التعليق
شارك
aboud424

aboud424

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

السلاام عليكم ورحمة الله الاخ سليم لقد قمت ببعض التعديلات على المرفق. اريد تحويل المواد الى الفورم الموحد في كل الاوراق بشرط ان نظيف المواد المشتركة في الغداء والعشاء. 

تقبل تحياتي 

Classeur3 (1).rar

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

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

Important Information

  I accept