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

aboud424 · يونيو 8, 2017

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

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

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

Classeur2.rar

**سليم حاصبيا** · يونيو 8, 2017

جرب هذا الكود

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

aboud424 · يونيو 8, 2017

شكرا بارك الله فيك هذا هو المطلوب. جزاك الله عنا خير الجزاء

aboud424 · يونيو 11, 2017

في 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

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

**سليم حاصبيا** · يونيو 11, 2017

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

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

aboud424 · يونيو 12, 2017

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 · يونيو 13, 2017

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

تقبل تحياتي

Classeur3 (1).rar

aboud424 · يونيو 15, 2017

شكرا لك استاذ سليم وفيت وكفيت بارك الله فيه. ربي يوفقك ويعطيك ما تتمنى.

تسجيل الدخول

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

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

aboud424

سليم حاصبيا

aboud424

aboud424

سليم حاصبيا

aboud424

aboud424

aboud424

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information