[حل شده] عملیات کپی و فیلتر به تعداد مشخص از یک شیت به شیت دیگر اکسل با توجه به تعداد آیتم ها

[sabertb]

سلام خسته نباشید به همه اساتید عزیز بنده در ایجاد یک حلقه شرطی If در VBA مشکل دارم اگر میتونید راهنماییم کنید
مشکلم اونجایی هست که می خواهم به تعداد اسامی موجود در صفحه R فرآیند کپی و فیلتر در صفحه Report انجام بشود و در صفحه RR ثبت گردد با شرایطی که در فایل توضیح دادم که وقتی تعداد اسامی کم یا زیاد شد به همان میزان عملیات مورد نظر ادامه یابد

[sabertb]

سلام مجدد
بی زحمت در مورد تکرار یک عملیات و پایان شرط در VBA کمک کنید ، می خوام یکی یکی اسامی صفحه R داخل صفحه Report فیلتر شود داخل صفحه RR کپی شود و تا زمانی که اسامی تکمیل شود ادامه یابد

[Amir Ghasemiyan]

سلام دوست عزيز
اين كد رو بررسي بفرماييد

Sub EI_CopyToRR()
'code by: Amir Ghasemiyan

Sheet2.Columns("J:O").Hidden = True
ActiveSheet.ShowAllData

ContractorsCount = Sheet4.Range("XFD1").End(xlToLeft).Column
LastRow = Sheet2.Range("A1048576").End(xlUp).Row
FilterRange = "A3:P" & LastRow
CopyRange = "B4:P" & LastRow

For i = 1 To ContractorsCount
    LastRRRow = Sheet5.Range("C1048576").End(xlUp).Row
    Contractor = Sheet4.Cells(1, i)
    Sheet2.Range(FilterRange).AutoFilter Field:=2, Criteria1:=Contractor
    Sheet2.Range(CopyRange).SpecialCells(xlCellTypeVisible).Copy
    Sheet5.Range("C" & LastRRRow + 1).PasteSpecial xlPasteValues
Next i

Sheet2.Columns("J:O").Hidden = False
Sheet2.Range(FilterRange).AutoFilter
End Sub

[M_ExceL]

سلام،

Sub M_E()
Dim rng, rngf, cg, cf As Range
Dim d, c As Long
    lcol = Sheets("r").Cells(1, Columns.Count).End(1).Column
    lrow = Sheets("Report").Cells(Rows.Count, 2).End(3).Row
    lrow2 = Sheets("rr").Cells(Rows.Count, 3).End(3).Row
    Set rng = Sheets("Report").Range("b2:b" & lrow)
    Set rngf = Sheets("r").Range(Sheets("r").Cells(1, 1), Sheets("r").Cells(1, lcol))
    Sheets("rr").Range("c3:q" & lrow2).ClearContents
    d = 2
        With Application
            .ScreenUpdating = False
                For Each cf In rngf
                    For Each cg In rng
                        If cf = cg Then
                            d = d + 1
                                For c = 1 To 15
                                    Sheets("rr").Cells(d, c + 2) = cg.Offset(0, c - 1)
                                Next c
                        End If
                    Next
                Next
            .ScreenUpdating = True
        End With
End Sub

[sabertb]

سلام دوست عزيز
اين كد رو بررسي بفرماييد

Sub EI_CopyToRR()
'code by: Amir Ghasemiyan

Sheet2.Columns("J:O").Hidden = True
ActiveSheet.ShowAllData

ContractorsCount = Sheet4.Range("XFD1").End(xlToLeft).Column
LastRow = Sheet2.Range("A1048576").End(xlUp).Row
FilterRange = "A3:P" & LastRow
CopyRange = "B4:P" & LastRow

For i = 1 To ContractorsCount
    LastRRRow = Sheet5.Range("C1048576").End(xlUp).Row
    Contractor = Sheet4.Cells(1, i)
    Sheet2.Range(FilterRange).AutoFilter Field:=2, Criteria1:=Contractor
    Sheet2.Range(CopyRange).SpecialCells(xlCellTypeVisible).Copy
    Sheet5.Range("C" & LastRRRow + 1).PasteSpecial xlPasteValues
Next i

Sheet2.Columns("J:O").Hidden = False
Sheet2.Range(FilterRange).AutoFilter
End Sub

ممنون از راهماییتون فقط همانطور که در فایل توضیح داده بودم {هر کدام از اسامی به ترتیب در سلول B2 کپی شود و سپس ...}این قسمتش کار نمیکنه ،
و این قسمت کد مشکل داره ارور میده

Sheet2.Columns("J:O").Hidden = True 

و همینطور می خواستم بگم امکانش هست تو نام گذاری ها از این فرمول استفاده بشه تا همین رنج فقط کپی بشود مانند توضیحات فایلم ؟

=OFFSET(Report!$B$3,1,0,COUNT(IF(Report!$A$4:$A$1000>0,Report!$A$4:$A$1000)),8),OFFSET(Report!$P$3,1,0,COUNT(IF(Report!$A$4:$A$1000>0,Report!$A$4:$A$1000)),1) 

- - - Updated - - -

سلام،

Sub M_E()
Dim rng, rngf, cg, cf As Range
Dim d, c As Long
    lcol = Sheets("r").Cells(1, Columns.Count).End(1).Column
    lrow = Sheets("Report").Cells(Rows.Count, 2).End(3).Row
    lrow2 = Sheets("rr").Cells(Rows.Count, 3).End(3).Row
    Set rng = Sheets("Report").Range("b2:b" & lrow)
    Set rngf = Sheets("r").Range(Sheets("r").Cells(1, 1), Sheets("r").Cells(1, lcol))
    Sheets("rr").Range("c3:q" & lrow2).ClearContents
    d = 2
        With Application
            .ScreenUpdating = False
                For Each cf In rngf
                    For Each cg In rng
                        If cf = cg Then
                            d = d + 1
                                For c = 1 To 15
                                    Sheets("rr").Cells(d, c + 2) = cg.Offset(0, c - 1)
                                Next c
                        End If
                    Next
                Next
            .ScreenUpdating = True
        End With
End Sub

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

[sabertb]

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

Sub EI_CopyToRR()'code by: Amir Ghasemiyan




ContractorsCount = Sheet4.Range("XFD1").End(xlToLeft).Column
LastRow = Sheet2.Range("A1048576").End(xlUp).Row
FilterRange = "A3:P" & LastRow
CopyRange = "rng"


For i = 1 To ContractorsCount
    LastRRRow = Sheet5.Range("C1048576").End(xlUp).Row
    Contractor = Sheet4.Cells(1, i)
    Sheet2.Range(FilterRange).AutoFilter Field:=2, Criteria1:=Contractor
    Sheet2.Range(CopyRange).SpecialCells(xlCellTypeVisible).Copy
    Sheet5.Range("C" & LastRRRow + 1).PasteSpecial xlPasteValues
Next i


Sheet2.Range(FilterRange).AutoFilter
End Sub

[Amir Ghasemiyan]

خب ظاهرا خودتون مشكلاتتون رو حل كرديد فقط مونده كپي كردن. در مورد كپي كردن راستش فكر كردم عمليات بي تاثيري باشه تو كدهام نياوردم
بقيه كدها رو هم بر اساس نام هايي كه تعريف كرديد تغيير دادم

Sub EI_CopyToRR()
'code by: Amir Ghasemiyan


ContractorsCount = Range("Contractor").Count
LastRow = Range("rng").Rows.Count + 3
FilterRange = "A3:P" & LastRow
CopyRange = "rng"


For i = 1 To ContractorsCount
    LastRRRow = Range("L_C").Row
    Contractor = Sheet4.Cells(1, i)
    Sheet2.Range("B2") = Contractor
    Sheet2.Range(FilterRange).AutoFilter Field:=2, Criteria1:=Contractor
    Sheet2.Range(CopyRange).SpecialCells(xlCellTypeVisible).Copy
    Sheet5.Range("C" & LastRRRow).PasteSpecial xlPasteValues
Next i


Sheet2.Range(FilterRange).AutoFilter
End Sub