[حل شده] جستجو نام و جمع سلول ها در چند شیت

[farhadhi62]

سلام خسته نباشید
من یک فایل اکسل دارم که باهاش ماهیانه کارکردیک سری مامور را در میاریم که نسبت به این کارکرد ها حقوق میگیرن
اما این کار تو حالت معمول زمان بر و وقت گیره اکسل شامل 6 شیت هست که 5 تا از شیت ها برنامه مامورین در مسیر های مختلف در طول یک هفته هست و یک شیت هم که برای جمع آوری کلی اطلاعات کارکرد مامور تو طول ماه هست


حالا من میخوام از شیت کارکرد مثلا تعداد مسیر های پرند1 را که آقای قراچه رفته است را از ۵ شیت دیگر با جستجو نام قراچه در سلول فقط پرند1 بگرده و هر چی قراچه پرند 1 رفته هست را به صورت عدد در شیت کارکرد اتوماتیک حساب و ثبت کنه

حالا نمیدونم میشه براش فرمولی تنظیم کرد یانه؟ اگه امکان داره ممنون میشم راهنمایی کنید
فایل اصلی هم پیوست کردم

[M_ExceL]

سلام خسته نباشید
من یک فایل اکسل دارم که باهاش ماهیانه کارکردیک سری مامور را در میاریم که نسبت به این کارکرد ها حقوق میگیرن
اما این کار تو حالت معمول زمان بر و وقت گیره اکسل شامل 6 شیت هست که 5 تا از شیت ها برنامه مامورین در مسیر های مختلف در طول یک هفته هست و یک شیت هم که برای جمع آوری کلی اطلاعات کارکرد مامور تو طول ماه هست
حالا من میخوام از شیت کارکرد مثلا تعداد مسیر های پرند1 را که آقای قراچه رفته است را از ۵ شیت دیگر با جستجو نام قراچه در سلول فقط پرند1 بگرده و هر چی قراچه پرند 1 رفته هست را به صورت عدد در شیت کارکرد اتوماتیک حساب و ثبت کنه
حالا نمیدونم میشه براش فرمولی تنظیم کرد یانه؟ اگه امکان داره ممنون میشم راهنمایی کنید
فایل اصلی هم پیوست کردم

سلام،
ابتدا ماکرو رو فعال کرده و روی باتن 1 در فایل پیوست کلیک کنید.

Sub M_Excel()

Dim i, lstr As Long
Dim celc, celn, celh, rngc, rngn, rngh As Range

lstr = Sheets(6).Cells(Rows.Count, 2).End(3).Row
Set rngc = Sheets(6).Range("b4:b" & lstr)
Set rngh = Sheets(6).Range("c1:ad1")
Sheets(6).Range("c4:ad" & lstr).ClearContents

    Application.ScreenUpdating = False
        
        For Each celc In rngc
            For i = 1 To Worksheets.Count - 1
            Set rngn = Sheets(i).Range("d3:j28")
                For Each celn In rngn
                    If Replace(celc, ChrW(32), "") = Replace(celn, ChrW(32), "") _
                    And celc <> Empty Then
                        For Each celh In rngh
                            If Replace(Sheets(i).Cells(celn.Row, 1), ChrW(32), "") _
                            = Replace(celh, ChrW(32), "") Then
                                Sheets(6).Cells(celc.Row, celh.Column) _
                                = Sheets(6).Cells(celc.Row, celh.Column) + 1
                            End If
                        Next
                    End If
                Next
            Next
        Next
        
    Application.ScreenUpdating = True

End Sub

توضیح :
تعدادی سلول مرج شده دارید ،
سلول های مرج باعث دردسر در کد نویسی و فرمول نویسی میشه که بنده این سلول ها رو از حالت مرج خارج کردم و ممکنه بعضی ردیف ها خالی شده باشد.
لذا شما فایل و نتیجه رو بررسی کنید ممکنه گزینه ها و ستون های دیگری بخواهید اضافه کنید که در این صورت کدها کمی باید اصلاح بشود.
یا حق.

[farhadhi62]

سلام،
ابتدا ماکرو رو فعال کرده و روی باتن 1 در فایل پیوست کلیک کنید.

Sub M_Excel()

Dim i, lstr As Long
Dim celc, celn, celh, rngc, rngn, rngh As Range

lstr = Sheets(6).Cells(Rows.Count, 2).End(3).Row
Set rngc = Sheets(6).Range("b4:b" & lstr)
Set rngh = Sheets(6).Range("c1:ad1")
Sheets(6).Range("c4:ad" & lstr).ClearContents

    Application.ScreenUpdating = False
        
        For Each celc In rngc
            For i = 1 To Worksheets.Count - 1
            Set rngn = Sheets(i).Range("d3:j28")
                For Each celn In rngn
                    If Replace(celc, ChrW(32), "") = Replace(celn, ChrW(32), "") _
                    And celc <> Empty Then
                        For Each celh In rngh
                            If Replace(Sheets(i).Cells(celn.Row, 1), ChrW(32), "") _
                            = Replace(celh, ChrW(32), "") Then
                                Sheets(6).Cells(celc.Row, celh.Column) _
                                = Sheets(6).Cells(celc.Row, celh.Column) + 1
                            End If
                        Next
                    End If
                Next
            Next
        Next
        
    Application.ScreenUpdating = True

End Sub

توضیح :
تعدادی سلول مرج شده دارید ،
سلول های مرج باعث دردسر در کد نویسی و فرمول نویسی میشه که بنده این سلول ها رو از حالت مرج خارج کردم و ممکنه بعضی ردیف ها خالی شده باشد.
لذا شما فایل و نتیجه رو بررسی کنید ممکنه گزینه ها و ستون های دیگری بخواهید اضافه کنید که در این صورت کدها کمی باید اصلاح بشود.
یا حق.

سلام مهندس خدا پدر و مادرتون رو براتون حفظ کنه عالی بود اصلا فکر نمیکردم بشه
فقط یه مورد اینکه تقریبا یک سوم نفرات خالی بود و محاسبه نمیشد البته یک سری اسامی فرق داشت تو دو تا جدول که ویرایش کردم چند تا اسامی هم اضافه کردم

بعد اینکه وقتی حالت ماکرو فعال هست نمیشه سیو کرد اکسل رو ارور زیر رو میده؟

مورد بعد اینکه فایل قبلی تعداد شیت های برنامه ماهانه 5 تا بود که من همه رو با هم تو یک شیت جدید ترکیب کردم که 100 درصد به کد نویسی جدید نیاز داره ولی خب شیت ها یکی شده و به یک شکل فکر کنم بهتره
بعد اینکه برای اطمینان میپرسم اسامی نفراتی که تو سلول کشیک هستند که توی کارکرد اضافه نمیشه؟چون این قسمت نباید باشه تو حساب کارکرد تو عکس زیر مشخص کردم

مهندس اگه بگید چطور کد ها رو نوشتید که هم یاد گرفتم و هم دیگه به شما زحمت نمیدم و ممنون تون میشم
فایل جدید هم ضمیمه کردم

[solar]

سلام
دوست عزیز من فکر میکنم اگه شما روش وارد کردن اطلاعات رو طبق اصول پایگاه داده انجام بدین میتونین با استفاده از جداول محوری خیلی راحت گزارش مورد نظرتون رو تهیه بکین
در این صورت دیگه نیازی به کدنویسی و فرمول های پیچیده نخواهید داشت

[farhadhi62]

یه مورد دیگه یادم رفت نمیشه اونجاهایی هم که طرف اون مسیر رو نرفته و تو جستجو مقداری پیدا نمیکنه رو عدد صفر بزاره

[M_ExceL]

یه مورد دیگه یادم رفت نمیشه اونجاهایی هم که طرف اون مسیر رو نرفته و تو جستجو مقداری پیدا نمیکنه رو عدد صفر بزاره

سلام،
ببخشید بابت تاخیر در پاسخ گویی، نبودم سر فرصت پاسخ را تقدیم خواهم کرد.

[M_ExceL]

سلام مهندس خدا پدر و مادرتون رو براتون حفظ کنه عالی بود اصلا فکر نمیکردم بشه
فقط یه مورد اینکه تقریبا یک سوم نفرات خالی بود و محاسبه نمیشد البته یک سری اسامی فرق داشت تو دو تا جدول که ویرایش کردم چند تا اسامی هم اضافه کردم

بعد اینکه وقتی حالت ماکرو فعال هست نمیشه سیو کرد اکسل رو ارور زیر رو میده؟

مورد بعد اینکه فایل قبلی تعداد شیت های برنامه ماهانه 5 تا بود که من همه رو با هم تو یک شیت جدید ترکیب کردم که 100 درصد به کد نویسی جدید نیاز داره ولی خب شیت ها یکی شده و به یک شکل فکر کنم بهتره
بعد اینکه برای اطمینان میپرسم اسامی نفراتی که تو سلول کشیک هستند که توی کارکرد اضافه نمیشه؟چون این قسمت نباید باشه تو حساب کارکرد تو عکس زیر مشخص کردم

مهندس اگه بگید چطور کد ها رو نوشتید که هم یاد گرفتم و هم دیگه به شما زحمت نمیدم و ممنون تون میشم
فایل جدید هم ضمیمه کردم

خواهش میکنم،
فایل پیوست جدید را بررسی بفرمایید.

Sub M_Excel()

Dim lstr As Long
Dim celc, celn, celh, rngc, rngn, rngh As Range

lstr = Sheets(2).Cells(Rows.Count, 2).End(3).Row
Set rngc = Sheets(2).Range("b4:b" & lstr)
Set rngh = Sheets(2).Range("c1:ad1")
Sheets(2).Range("c4:ad" & lstr).ClearContents
Set rngn = Sheets(1).Range("d3:aj29")
Sheets(2).Range("c4:ad" & lstr).Value = 0
    Application.ScreenUpdating = False
        
        For Each celc In rngc
                For Each celn In rngn
                    If Replace(celc, ChrW(32), "") = Replace(celn, ChrW(32), "") _
                    And celc <> Empty Then
                        For Each celh In rngh
                            If Replace(Sheets(1).Cells(celn.Row, 1), ChrW(32), "") _
                            = Replace(celh, ChrW(32), "") Then
                                Sheets(2).Cells(celc.Row, celh.Column) _
                                = Sheets(2).Cells(celc.Row, celh.Column) + 1
                            End If
                        Next
                    End If
                Next
        Next
        
    Application.ScreenUpdating = True

End Sub

فایل های دارای کد نویسی رو می بایست با فرمت excel macro-Enabled Workbook (پسوند xlsm) ذخیره نمایید.

[farhadhi62]

خواهش میکنم،
فایل پیوست جدید را بررسی بفرمایید.
فایل های دارای کد نویسی رو می بایست با فرمت excel macro-Enabled Workbook (پسوند xlsm) ذخیره نمایید.

عالی دست شما درد نکنه درسته