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

جمع الايراد من الملفات بدون جمع الصنف او العدد

محمود الحربي

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

 مشاركة

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

محمود الحربي

محمود الحربي

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

اريد جمع الايراد من الملفات بدون جمع الصنف او العدد

 

يعني اني انقل ايراد شهر واحد من الملف رقم 1 وثم انقل تحته في الجدول ايراد الملف رقم 2 وثم الملف رقم 3

و الخ

 

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

بحيث يصبح لي مكون من 12 شيت  وتعبر عن ايرادي 12 شهر من جميع الملفات مجمعه

 

 

شاكر ومقدر لكم جميعاً مقدماً

 

new.rar

الـعيدروس

الـعيدروس

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

جميع بيانات الملفات لشهر واحد

حسب ملفاتك الحاليه ؟

اضفت  في بعض الملفات اشهر وهميه

  بمعنى بيانات لـ 6 اشهر

جرب الكود التالي

حط الملفات بنفس فولدر الملف الذي به الكود 

Sub Ali_Tran_Fil()
    Dim Pth As String
    Dim F_il As String
    Dim S_Nm As String
    Dim My_Vlu() As Variant
    Dim Lr, Lrr, R, Dy, Ar, Az, Ar_O, ii, rr, pp, Cr
    Dim Date_M As Date
    Dim O_Wp As Workbook
    Dim ws As Worksheet
    Dim Sh As Worksheet
    Dim Mi_A As Worksheet
    Dim sht As Worksheet
    Set Mi_A = Sheets(1)
    De_Sht CStr(Mi_A.Name)
    Apc_Ali False
    '--------------------------------------------------------------------
    Pth = ThisWorkbook.Path & "\"  '' مسار الملفات بنفس مسار الملف الحالي
    '--------------------------------------------------------------------
    F_il = Dir(Pth & "*.xlsx") '' xlsx صيغة ملفات الاكسل التي سيتم جلب بياناتها
    '--------------------------------------------------------------------
    ReDim Preserve My_Vlu(1 To 10000, 1 To 6)
    '--------------------------------------------------------------------
    Do While F_il <> ""
        If F_il <> ThisWorkbook.Name Then
             S_Nm = Pth & F_il
                Set O_Wp = Workbooks.Open(S_Nm)
                Set ws = O_Wp.Sheets(1)
                 Lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        For R = 2 To Lr
          I = I + 1
           My_Vlu(I, 1) = ws.Cells(R, 3)
             My_Vlu(I, 2) = ws.Cells(R, 1)
             My_Vlu(I, 3) = ws.Cells(R, 2)
             My_Vlu(I, 4) = ws.Cells(R, 6)
             My_Vlu(I, 5) = ws.Cells(R, 7)
           My_Vlu(I, 6) = Split(F_il, ".")(0)
        Next R
           O_Wp.Close False
           F_il = Dir
       End If
    Loop
    '--------------------------------------------------------------------
    Mi_A.Range("A2").Resize(UBound(My_Vlu, 1), UBound(My_Vlu, 2)) = My_Vlu
    '--------------------------------------------------------------------
    Mi_A.Sort.SortFields.Add Key:=Mi_A.Range("D2", Mi_A.Range("D2").End(xlDown)), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Mi_A.Sort
        .SetRange Mi_A.Range("A2:F" & Mi_A.Range("A1").End(xlDown).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '--------------------------------------------------------------------
   With CreateObject("scripting.dictionary")
    For ii = LBound(My_Vlu, 1) To UBound(My_Vlu, 1)
      If My_Vlu(ii, 1) <> "" Then
        If IsDate(My_Vlu(ii, 4)) Then
          Date_M = My_Vlu(ii, 4)
          Dy = .Item(Month(Date_M))
        End If
       End If
     Next ii
    Ar = Split(Join(.Keys, ","), ",")
    End With
    '--------------------------------------------------------------------
    For rr = LBound(Ar) To UBound(Ar)
       If IsError(Evaluate("'" & Ar(rr) & "'!A1")) Then
          Set Sh = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
            With Sh
                .Name = CStr(Ar(rr))
                 Az = Array("رقم العميل", "العدد", "الصنف", "التاريخ", "السعر", "إسم الملف")
              With .Range("A1")
                .Offset(0, 0).Resize(1, UBound(Az) + 1) = Az
              End With
                 .Columns(1).ColumnWidth = 29.29
                 .Columns(2).ColumnWidth = 8.43
                 .Columns(3).ColumnWidth = 15
                 .Columns(4).ColumnWidth = 16.14
                 .Columns(5).ColumnWidth = 8.43
                 .Columns(6).ColumnWidth = 8.43
           End With
      End If
    Next rr
    '--------------------------------------------------------------------
Ar_O = Mi_A.Range("A1").CurrentRegion.Value
 For Each sht In Sheets
  If Not sht.Index = 1 Then
    For pp = 1 To UBound(Ar_O, 1)
      If IsDate(Ar_O(pp, 4)) Then
        If Trim(Month(Ar_O(pp, 4))) = Trim(sht.Name) Then
          With sht
             Lrr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            .Cells(Lrr, 1) = Ar_O(pp, 1)
            .Cells(Lrr, 2) = Ar_O(pp, 2)
            .Cells(Lrr, 3) = Ar_O(pp, 3)
            .Cells(Lrr, 4) = Ar_O(pp, 4)
            .Cells(Lrr, 5) = Ar_O(pp, 5)
            .Cells(Lrr, 6) = Ar_O(pp, 6)
          End With
        End If
      End If
    Next pp
   End If
  Next sht
  '****
   Sh_S
  '****
  '\\\\\\\\
    Cr = Split(Mi_A.UsedRange.Address, "$")(4)
    Mi_A.Range("A2:F" & IIf(Cr = 1, 2, Cr)).ClearContents
  '////////
  Apc_Ali True
  '************************************
  Set O_Wp = Nothing: Set ws = Nothing
  Set Sh = Nothing: Set Mi_A = Nothing
  Set sht = Nothing: Erase My_Vlu
End Sub
Private Sub B_Set(Sh_N())
Dim T_m
Dim I, J
'----------------------------------
Apc_Ali False
For I = LBound(Sh_N) To UBound(Sh_N)
    For J = I To UBound(Sh_N)
    If Sh_N(I) > Sh_N(J) Then
        T_m = Sh_N(I)
        Sh_N(I) = Sh_N(J)
        Sh_N(J) = T_m
    End If
Next J
Next I
Apc_Ali True
'----------------------------------
End Sub
Private Sub Sh_S()
Dim Sht_a As Worksheet
Dim My_Sh()
Dim I
'------------------------------------------
Apc_Ali False
ReDim My_Sh(ThisWorkbook.Worksheets.Count)
I = LBound(My_Sh)
For Each Sht_a In ThisWorkbook.Worksheets
       My_Sh(I) = Sht_a.Name
       I = I + 1
Next Sht_a
'-----------
B_Set My_Sh
'-----------
For I = LBound(My_Sh) + 1 To UBound(My_Sh)
  If Sheets(My_Sh(I)).Index <> 1 Then
     Worksheets(My_Sh(I)).Move After:=Worksheets(ThisWorkbook.Worksheets.Count)
  End If
Next I
Apc_Ali True
'------------------------------------------
End Sub
Public Function De_Sht(ByVal Nm_S As String)
Dim Sh_D As Worksheet
''------------------------------------
For Each Sh_D In Worksheets
    Application.DisplayAlerts = False
       If Sh_D.Name <> Nm_S Then Sh_D.Delete
    Application.DisplayAlerts = True
Next Sh_D
''------------------------------------
Set Sh_D = Nothing
End Function
Public Function Apc_Ali(Bll As Boolean)
''------------------------------------
With Application
    .Calculation = IIf(Bll, -4105, -4135)
    .ScreenUpdating = Bll
    .EnableEvents = Not Bll
End With
''------------------------------------
End Function

 

والمرفقات الملف وبه الكود

 

new_Ali.rar

تم تعديل بواسطه الـعيدروس
  • Like 4
محمود الحربي

محمود الحربي

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

استاذي العيدروس

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

 

فضلاً لا امراً اريد اضافة 12 شهر على الكود فقط

واذا كان الملفات الي بسحي منها الايراد توجد بها شيتات اخرى للمصاريف 

كيف اسحب فقط بس شيت الايراد 

حيث ان شيت الايراد مسجل في جميع المفات 

ايراد - 1 

ايراد - 2 

ايراد - 3

ايراد - 4 

ايراد - 5 

ايراد - 6 

ايراد - 7 

ايراد - 8 

ايراد - 9

ايراد - 10 

ايراد - 11 

ايراد - 12 

ومثله في 25 ملف 

 

الملف الذي اريد سحب منه الايراد

http://up.top4top.net/downloadf-top4top_c382b97bd21-rar.html

 

الـعيدروس

الـعيدروس

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

هل تقصد يوجد بكل ملف 12 ورقة  مسماه ايراد - 1 و 2 الخ .. تريد استيرادها الى الملف الحالي

وهكذا في باقي الـ 25 ملف الاخر ؟

محمود الحربي

محمود الحربي

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

نعم 

عندي 25 ملف بمسمي C 101  الخ

كل ملف فيه  ايراد - 1  الخ

اريد تجميع الايراد في الملف المرفق اعلى لكل شهر من جميع الملفات

 

ارفق لك الملف الي اعمل عليه في الاساس يمكن تكون الفكره توصل افضل 

2015.rar

تم تعديل بواسطه محمود الحربي
الـعيدروس

الـعيدروس

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

حاولت ازبط كود يقوم بعمل ماتريد

الا انه يصل الى ملفك الذي ارفقته مؤخراً ويهنج

 والى الان لم اكتشف المشكله

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

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

تحياتي

تم تعديل بواسطه الـعيدروس
محمود الحربي

محمود الحربي

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

يكفيني منك استاذي خدمتك ومساعدتك للجميع

جعلها فـي ميزان حسناتك

 

ممكن  ترفق الملف الي عملته يمكن احد يفيدنا فيه من الأساتذة الكرام

تم تعديل بواسطه محمود الحربي
الـعيدروس

الـعيدروس

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

هذا الكود

جرب حط بيانات في الاوراق

المسماه ايراد في جميع الملفات

امل ان يعمل معك

  

Sub Ali_Tran_Fil()
    Dim My_Bok As Workbook
    Dim Sheet As Worksheet
    Dim O_Wp As Workbook
    Dim Sh As Worksheet
    Dim Ch_Nm As Worksheet
    Dim Sh1 As Worksheet
    Dim sht As Worksheet
    Dim Ths_Nm$, Pth$, F_il$, S_Nm$, Az
    Dim Lr&, Lrow&, Lss&, Lrr&, ii%, Ar, Ar_O, rr%, pp%
    Dim My_Vlu As Variant
    On Error Resume Next
    Set My_Bok = ThisWorkbook ''
    Set Sheet = My_Bok.Sheets(1) ''
    De_Sht CStr(Sheet.Name)
    ''**************
    Ths_Nm = "ايراد" ''
    ''**************
    Apc_Ali False
    '--------------------------------------------------------------------
    Pth = ThisWorkbook.Path & "\"  '' مسار الملفات بنفس مسار الملف الحالي
    '--------------------------------------------------------------------
    F_il = Dir(Pth & "*.xls*") '' xlsx صيغة ملفات الاكسل التي سيتم جلب بياناتها
    '--------------------------------------------------------------------
    '--------------------------------------------------------------------
    Do While F_il <> My_Bok.Name
         S_Nm = Pth & F_il
         Set O_Wp = Workbooks.Open(S_Nm) ''
    '--------------------------------------------------------------------
      For Each Sh In O_Wp.Worksheets ''
         Set Ch_Nm = O_Wp.Sheets(Sh.Name) ''
         If Ch_Nm.Name Like "*" & Ths_Nm & "*" Then
              With Ch_Nm
                  O_Wp.Activate
                  .Activate
                  .Unprotect
                  Lr = 103 ''
                  Application.Union(.Range("C12:C" & Lr), .Range("A12:A" & Lr), _
                  .Range("B12:B" & Lr), .Range("F12:F" & Lr), _
                  .Range("G12:G" & Lr)).Copy
              End With
              With Sheet
                  My_Bok.Activate
                  .Activate
                  Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                  .Range("A" & Lrow).PasteSpecial xlPasteValues
                  Lss = .Cells(.Rows.Count, 1).End(xlUp).Row
                  .Range(.Cells(Lrow, 6), .Cells(Lss, 6)) = Split(F_il, ".")(0) & " Sheet_Nm\ " & Ch_Nm.Name
              End With
         End If
     Next Sh
    '--------------------------------------------------------------------
             O_Wp.Close False
             F_il = Dir
    Loop
With Sheet
      .Sort.SortFields.Add Key:=.Range("D2", Sheet.Range("D2").End(xlDown)), _
     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheet.Sort
        .SetRange .Range("A2:F" & .Range("A1").End(xlDown).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    My_Vlu = .Range(.Range("A2"), .Range("A2").End(xlDown).Resize(1, 5)) ''
'    '--------------------------------------------------------------------
   With CreateObject("scripting.dictionary")
    For ii = LBound(My_Vlu, 1) To UBound(My_Vlu, 1) ''
      If My_Vlu(ii, 1) <> "" Then
        If IsDate(My_Vlu(ii, 4)) Then
          Date_M = My_Vlu(ii, 4)
          Dy = .Item(Month(Date_M))
        End If
       End If
     Next ii
    Ar = Split(Join(.Keys, ","), ",") ''
    End With
End With
'    '--------------------------------------------------------------------
    For rr = LBound(Ar) To UBound(Ar)
       If IsError(Evaluate("'" & Ar(rr) & "'!A1")) Then
          Set Sh1 = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
            With Sh1
                .Name = CStr(Ar(rr))
                 Az = Array("رقم العميل", "العدد", "الصنف", "التاريخ", "السعر", "إسم الملف")
              With .Range("A1")
                .Offset(0, 0).Resize(1, UBound(Az) + 1) = Az
              End With
                 .Columns(1).ColumnWidth = 29.29
                 .Columns(2).ColumnWidth = 8.43
                 .Columns(3).ColumnWidth = 15
                 .Columns(4).ColumnWidth = 16.14
                 .Columns(5).ColumnWidth = 8.43
                 .Columns(6).ColumnWidth = 8.43
           End With
      End If
    Next rr
'    '--------------------------------------------------------------------
Ar_O = Sheet.Range("A1").CurrentRegion.Value ''
 For Each sht In Sheets
  If Not sht.Index = 1 Then
    For pp = 1 To UBound(Ar_O, 1)
      If IsDate(Ar_O(pp, 4)) Then
        If Trim(Month(Ar_O(pp, 4))) = Trim(sht.Name) Then
          With sht
             Lrr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            .Cells(Lrr, 1) = Ar_O(pp, 1)
            .Cells(Lrr, 2) = Ar_O(pp, 2)
            .Cells(Lrr, 3) = Ar_O(pp, 3)
            .Cells(Lrr, 4) = Ar_O(pp, 4)
            .Cells(Lrr, 5) = Ar_O(pp, 5)
            .Cells(Lrr, 6) = Ar_O(pp, 6)
          End With
        End If
      End If
    Next pp
   End If
  Next sht
'  '****
   Sh_S
'  '****
'  '\\\\\\\\
    Cr = Split(Sheet.UsedRange.Address, "$")(4)
    Sheet.Range("A2:F" & IIf(Cr = 1, 2, Cr)).ClearContents
''  '////////
  Apc_Ali True
''  '************************************
Set My_Bok = Nothing: Set Sheet = Nothing: Set O_Wp = Nothing
Set Sh = Nothing: Set Ch_Nm = Nothing: Set Sh = Nothing
Set Sh1 = Nothing: Set sht = Nothing
End Sub
Private Sub B_Set(Sh_N())
Dim T_m
Dim I, J
'----------------------------------
Apc_Ali False
For I = LBound(Sh_N) To UBound(Sh_N)
    For J = I To UBound(Sh_N)
    If Sh_N(I) > Sh_N(J) Then
        T_m = Sh_N(I)
        Sh_N(I) = Sh_N(J)
        Sh_N(J) = T_m
    End If
Next J
Next I
Apc_Ali True
'----------------------------------
End Sub
Private Sub Sh_S()
Dim Sht_a As Worksheet
Dim My_Sh()
Dim I
'------------------------------------------
Apc_Ali False
ReDim My_Sh(ThisWorkbook.Worksheets.Count)
I = LBound(My_Sh)
For Each Sht_a In ThisWorkbook.Worksheets
       My_Sh(I) = Sht_a.Name
       I = I + 1
Next Sht_a
'-----------
B_Set My_Sh
'-----------
For I = LBound(My_Sh) + 1 To UBound(My_Sh)
  If Sheets(My_Sh(I)).Index <> 1 Then
     Worksheets(My_Sh(I)).Move After:=Worksheets(ThisWorkbook.Worksheets.Count)
  End If
Next I
Apc_Ali True
'------------------------------------------
End Sub
Public Function De_Sht(ByVal Nm_S As String)
Dim Sh_D As Worksheet
''------------------------------------
For Each Sh_D In Worksheets
    Application.DisplayAlerts = False
       If Sh_D.Name <> Nm_S Then Sh_D.Delete
    Application.DisplayAlerts = True
Next Sh_D
''------------------------------------
Set Sh_D = Nothing
End Function
Public Function Apc_Ali(Bll As Boolean)
''------------------------------------
With Application
    .DisplayAlerts = Bll
    .Calculation = IIf(Bll, -4105, -4135)
    .ScreenUpdating = Bll
    .EnableEvents = Bll
End With
''------------------------------------
End Function

 

الـعيدروس

الـعيدروس

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

اذا امكن تعطيني نسخه من ملفاتك كما هيا

 فقط تمسح البيانات التي بها خصوصيه وتستبدلها بوهميه

     وارسلها على ايميلي وان شاء الله ازبط لك الكود كي يعمل على اكمل وجه

     Email : aahfm2015@gmail.com

    تحياتي

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