پرفروش ترين
برترين
آخرين محصولات فروشگاه
فایل الکترونیکی آموزش اکسل پیشرفته ۲۰۱۰
آموزش ایجاد فایل چندکاربره با سطح دسترسی مشخص
یوزرفرم پیشرفته -Advanced  User Form
داشبورد (مقدماتی) – Dashboards(Elementary)
ابزارهای اعتبار سنجی و اخطار دهنده
بسته آموزشی userform
مدیریت و کنترل خطا در اکسل
توابع متنی
گرافیک در اکسل
جزوه آموزشی جداول و نمودارهای پاشنه ای
فایل آموزشی نحوه تهیه فرمت عددی دلخواه یا custom number format cell
آموزش ایجاد فایل چندکاربره با سطح دسترسی مشخص
صفحه 1 از 2 12 آخرینآخرین
نمایش نتایج: از شماره 1 تا 10 , از مجموع 11

موضوع: دسته بندی اطلاعات در جدول های مربوطه

  1. #1


    آخرین بازدید
    5 ساعت پیش
    تاریخ عضویت
    September_2014
    نوشته ها
    50
    امتیاز
    13
    سپاس
    2
    سپاس شده
    3 در 3 پست

    دسته بندی اطلاعات در جدول های مربوطه

    سلام و عرض ادب خدمت شما
    نیازمند ماکرویی برای دسته بندی اطلاعات در جدول های مربوطه هستم.
    لطفا ابتدا ماکرو زیر را در شیت 1 اجرا کنید و سپس ادامه پروسه را طبق اطلاعات داده شده در شیت 2 تکمیل فرمایید
    کد:
    Sub Macro1()
    '
    ' Macro1 Macro
    '
    Application.ScreenUpdating = False
        Dim Col, i, j, f, g As Integer
        Dim Rng As String
        With Application.WorksheetFunction
            Col = 2
            j = 1
            f = 1
            g = 4
            
            For i = 2 To 1000 Step 1
                Rng = Cells(i, Col)
                If LCase(Rng) = "80" Then
                    Cells(f, g) = Rng
                    f = f + 1
                Else
                    If .CountIf(Range(Cells(1, g), Cells(1000, g)), Rng) > 0 Then
                        Cells(f, g) = Rng
                        f = f + 1
                    Else
                        g = g + 1
                        f = 1
                        Cells(f, g) = Rng
                        f = f + 1
                    End If
                End If
            Next
        End With
    End Sub
    به فایل مراجعه شود.
    ممنون از راهنمایی شما
    فايل هاي پيوست شده فايل هاي پيوست شده
    پاسخ مورد نظر براي اين تاپيك ارسال شده است.

  2.  

  3. #2


    آخرین بازدید
    2 ساعت پیش
    تاریخ عضویت
    September_2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    3,047
    امتیاز
    9047
    سپاس
    5,989
    سپاس شده
    7,383 در 2,450 پست

    سلام دوست عزيز
    اميدوارم سوالتون رو درست متوجه شده باشم

    كدهاتون رو يه مقدار تغيير دادم و اصلاحات لازم رو هم انجام دادم. بررسي بفرماييد لطفا

    کد:
    Sub Macro1()
    Dim Col, i, j, f, g As Integer
    Dim Rng As String
    With Application.WorksheetFunction
        Col = 2
        j = 1
        f = 2
        g = 4
        Lrow = Range("B1").End(xlDown).Row
        For i = 2 To Lrow
            Rng = Cells(i, Col)
            If LCase(Rng) <> "80" And .CountIf(Range(Cells(1, g), Cells(1000, g)), Rng) <= 0 Then
                g = g + 1
                f = 2
            End If
            Cells(f, g) = Rng
            f = f + 1
        Next
        For q = 4 To g
            counter = .CountIfs(Range(Cells(2, q), Cells(1000, q)), "<>80", Range(Cells(2, q), Cells(1000, q)), "<>")
            If counter <> 0 Then Cells(1, q) = counter
        Next q
    End With
    End Sub

  4. سپاس ها (1)


  5. #3


    آخرین بازدید
    5 ساعت پیش
    تاریخ عضویت
    September_2014
    نوشته ها
    50
    امتیاز
    13
    سپاس
    2
    سپاس شده
    3 در 3 پست

    نقل قول نوشته اصلی توسط Amir Ghasemiyan نمایش پست ها
    سلام دوست عزيز
    اميدوارم سوالتون رو درست متوجه شده باشم

    كدهاتون رو يه مقدار تغيير دادم و اصلاحات لازم رو هم انجام دادم. بررسي بفرماييد لطفا

    کد:
    Sub Macro1()
    Dim Col, i, j, f, g As Integer
    Dim Rng As String
    With Application.WorksheetFunction
        Col = 2
        j = 1
        f = 2
        g = 4
        Lrow = Range("B1").End(xlDown).Row
        For i = 2 To Lrow
            Rng = Cells(i, Col)
            If LCase(Rng) <> "80" And .CountIf(Range(Cells(1, g), Cells(1000, g)), Rng) <= 0 Then
                g = g + 1
                f = 2
            End If
            Cells(f, g) = Rng
            f = f + 1
        Next
        For q = 4 To g
            counter = .CountIfs(Range(Cells(2, q), Cells(1000, q)), "<>80", Range(Cells(2, q), Cells(1000, q)), "<>")
            If counter <> 0 Then Cells(1, q) = counter
        Next q
    End With
    End Sub
    ممنون از پاسخ شما
    این قسمت آبی رنگ را انجام می دهد.
    مسله ای که هست خواهش میکنم اگه امکان داره شیت شماره 2 رو ملاحظه کنید
    کد ماکرو عنایت کنید که تمام بخش های شیت دو را انجام دهد . این زحمتی که شما کشیدید فقط قسمت آبی رنگ را حل میکند.

    - - - Updated - - -

    در شیت 2 بخش های دیگری هم بایستی تکمیل شود.
    البته با عنایت ویژه جنابعالی

    - - - Updated - - -

    لطفا مثل همین کدی که زحمت کشیدید ، همین جا بگذارید ممنون .

    - - - Updated - - -

    لطفا مثل همین کدی که زحمت کشیدید ، همین جا بگذارید ممنون .

  6. #4


    آخرین بازدید
    5 ساعت پیش
    تاریخ عضویت
    September_2014
    نوشته ها
    50
    امتیاز
    13
    سپاس
    2
    سپاس شده
    3 در 3 پست


    لطفاطبق این مراحل زجمت بکشید:
    وقتی f8 زده میشه به ترتیب این موارد انجام شوند:
    1.نوشته شدن حروف SN به رنگ موجود در شیت 2 در سلول J1
    2.نوشته شدن شماره ردیف گروه در سلول K1 ( که از ستون Aاستخراج میشه)
    3.نوشته شدن کلمه CODE به رنگ موجود در شیت 2 در سلول با یک سطر فاصله نسبت به K1
    4.نوشته شدن کدها به ترتیب قبل که زحمت کشیدید
    5.جمع ستونی سلول های حاوی کد به جز کد 80 در بعد از یک سطر فاصله در بالای آن
    6.تکرار این مراحل به ترتیب شماره ردیف هر گروه ( که از ستون A استخراج میشه)با یک خط فاصله نسبت به طولانی ترین ستون گروه قبلی

    ویرایش توسط mahdi2013 : یک هفته پیش در ساعت 16:24

  7. #5


    آخرین بازدید
    2 ساعت پیش
    تاریخ عضویت
    September_2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    3,047
    امتیاز
    9047
    سپاس
    5,989
    سپاس شده
    7,383 در 2,450 پست

    اميدوارم اين بار منظورتون رو درست متوجه شده باشم

    کد:
    Sub Macro1()
    Dim c, i, r, f, g As Integer
    Dim Rng As String
    With Application.WorksheetFunction
        c = 2
        r = 2
        Lrow = Range("B1").End(xlDown).Row
        For k = 1 To .Max(Range(Cells(2, 1), Cells(Lrow, 1)))
            f = r
            g = 4
            Max = 0
            For i = 2 To Lrow
                If Cells(i, c - 1) = k Then
                    Rng = Cells(i, c)
                    If LCase(Rng) <> "80" And .CountIf(Range(Cells(r, g), Cells(f, g)), Rng) <= 0 Then
                        g = g + 1
                        f = r
                    End If
                    Cells(f, g) = Rng
                    f = f + 1
                If f > Max Then Max = f
                End If
            Next
            For q = 4 To g
                counter = .CountIfs(Range(Cells(r, q), Cells(r + Max, q)), "<>80", Range(Cells(r, q), Cells(r + Max, q)), "<>")
                If counter <> 0 Then Cells(r - 1, q) = counter
            Next q
            r = Max + 3
        Next k
    End With
    End Sub


  8. #6


    آخرین بازدید
    5 ساعت پیش
    تاریخ عضویت
    September_2014
    نوشته ها
    50
    امتیاز
    13
    سپاس
    2
    سپاس شده
    3 در 3 پست

    درود بی کران بر شما ، واقعا مرحبا

  9. #7


    آخرین بازدید
    2 ساعت پیش
    تاریخ عضویت
    September_2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    3,047
    امتیاز
    9047
    سپاس
    5,989
    سپاس شده
    7,383 در 2,450 پست

    نقل قول نوشته اصلی توسط mahdi2013 نمایش پست ها
    درود بی کران بر شما ، واقعا مرحبا
    خواهش ميكنم. لطفا بررسي كنيد اگر مشكل ديگه اي نبود تاپيك رو حل شده كنيد

    اين نكته رو هم عرض كنم كه در تعداد sn محدوديتي نداريد. اين كد بطور اتومات همه رو براتون اضافه ميكنه

  10. #8


    آخرین بازدید
    5 ساعت پیش
    تاریخ عضویت
    September_2014
    نوشته ها
    50
    امتیاز
    13
    سپاس
    2
    سپاس شده
    3 در 3 پست

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

  11. #9


    آخرین بازدید
    2 ساعت پیش
    تاریخ عضویت
    September_2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    3,047
    امتیاز
    9047
    سپاس
    5,989
    سپاس شده
    7,383 در 2,450 پست

    نقل قول نوشته اصلی توسط mahdi2013 نمایش پست ها
    نفرمایید ، ایراد از خودمه که اطلاعات کمی نسبت به کد نویسی دارم و همین امر باعث میشه که متوسل به لطف جنابعالی و دوستان شویم.
    اگر لطف خودتونو کامل کنید و طبق گرافیک شیت دو خروجی کار بعد از اجرای ماکرو شکل بگیره منو واقعا شرمنده میکنید.
    البته لطف میکنید.

    خواهش میکنم دوست عزیز
    خدمت شما:

    کد:
    Sub Macro1()
    Dim c, i, r, f, g As Integer
    Dim Rng As String
    With Application.WorksheetFunction
        c = 2
        r = 3
        Lrow = Range("B1").End(xlDown).Row
        For k = 1 To .Max(Range(Cells(2, 1), Cells(Lrow, 1)))
            f = r
            g = 5
            Max = 0
            For i = 2 To Lrow
                If Cells(i, c - 1) = k Then
                    Rng = Cells(i, c)
                    If LCase(Rng) <> "80" And .CountIf(Range(Cells(r, g), Cells(f, g)), Rng) <= 0 Then
                        g = g + 1
                        f = r
                    End If
                    Cells(f, g) = Rng
                    f = f + 1
                If f > Max Then Max = f
                End If
            Next
            For q = 5 To g
                counter = .CountIfs(Range(Cells(r, q), Cells(r + Max, q)), "<>80", Range(Cells(r, q), Cells(r + Max, q)), "<>")
                If counter <> 0 Then Cells(r - 2, q) = counter
            Next q
            style r, Max, g, k
            r = Max + 3
        Next k
    End With
    End Sub
    
    
    Sub style(r, m, g, k)
    Cells(r - 2, 4) = "SN"
    Cells(r - 2, 5) = k
    Cells(r, 5) = "CODE"
    
    
    Cells(r - 2, 4).Interior.Color = 49407
    Cells(r - 2, 5).Interior.Color = 65535
    Cells(r, 5).Interior.Color = 255
    Range(Cells(r - 2, 6), Cells(r - 2, g)).Interior.Color = 15773696
    Range(Cells(r, 6), Cells(m - 1, g)).Interior.Color = 15461375
    
    
    Cells(r, 5).BorderAround xlContinuous, xlMedium
    Range(Cells(r - 2, 6), Cells(r - 2, g)).BorderAround xlContinuous, xlMedium
    Range(Cells(r, 6), Cells(m - 1, g)).BorderAround xlContinuous, xlMedium
    End Sub

  12. #10


    آخرین بازدید
    5 ساعت پیش
    تاریخ عضویت
    September_2014
    نوشته ها
    50
    امتیاز
    13
    سپاس
    2
    سپاس شده
    3 در 3 پست

    من شما را هنرمند خطاب میکنم.
    از این همه زیبایی ممنونم.

  13. سپاس ها (1)



صفحه 1 از 2 12 آخرینآخرین

اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. ليست حقوق و دستمزد براي استفاده دوستان
    توسط misammisam در انجمن فاکتور های فروش و حقوق و دستمزد،چک
    پاسخ ها: 12
    آخرين نوشته: 30 _ 12 _ 2017, 22:24
  2. ساخت لیستهای وابسته در اکسل با استفاده از data validation
    توسط mohsen9401 در انجمن توابع اکسل - Excel Functions
    پاسخ ها: 3
    آخرين نوشته: 10 _ 07 _ 2014, 16:00
  3. قسمت دوم: توابع پركاربرد حسابداري در اكسل - تابع Straight Line Depreciation - استهلاك به روش خط مستقيم
    توسط misammisam در انجمن آموزش ترفند ها و توابع اکسل در حسابداری
    پاسخ ها: 0
    آخرين نوشته: 07 _ 05 _ 2014, 23:48
  4. بسته شدن اكسل در استفاده از ابزار Table
    توسط arsalan135 در انجمن سوالات اكسل - Excel Questions
    پاسخ ها: 5
    آخرين نوشته: 12 _ 02 _ 2014, 12:19
  5. ساخت لیستهای وابسته در اکسل با استفاده از data validation
    توسط mohsen9401 در انجمن ترفندهای اکسل Excel Tricks
    پاسخ ها: 1
    آخرين نوشته: 24 _ 10 _ 2012, 14:50

بازدید کنندگان با جستجو های زیر این صفحه را پیدا کرده اند

انجمن اكسل ايران , اكسل , اكسس , سوال و جواب اكسل , سوال اكسس , انجمن اكسل ايران , توابع اكسل, آموزش اكسل, آموزش اكسس, VBA, ويژوال بيسيك

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
  • BB code ها فعال هستند
  • شکلک ها فعال هستند
  • کد [IMG] فعال است
  • کد [VIDEO] فعال است
  • کد HTML غیر فعال است