[حل شده] ماکرو برای پاک کردن هوشمند

[taocom52]

سلام بر اساتید و دوستان عزیز
من فایل اکسلی دارم که تعدا زیادی جدول که دقیقا شبیه هم هستند داره و فقط محتوای سلولهای این جداول متفاوتند ، در فایلی که پیوست کردم نمونه کوچکی از موضوع را که مد نظرم هست را نشان دادم ، به ازای هرجدول سطری وجود دارد که اطلاعات آن جدول در سطر متناظرش منتقل می شود مثلا اطلاعات جدول 1 در سطری که شماره جدول ان 1 است (که با رنگ قرمز نشان داده ام) منتقل میشود. تعدادی از سلولهای جداول به خاطر اینکه محتوایشان فرمول است قفل و hiden شده اند و تعدادی هم جهت ورود اطلاعات باز هستند ، حال من کدی نوشتم (با کمک شما اساتید عزیز) که وقتی شماره جدولی را انتخواب میکنم (شماره قرمز که عنوان شماره جدول دارند را) و دکمه بایگانی را میزنم اطلاعات آن سطر در اولین سطر خالی در شیت 2 کپی میشود و اصطلاحا بایگانی میکنم ، حال میخواهم کدی نوشته شود که بعد از بایگانی کردن مثلا اطلاعات سطر جدول شماره 1 ، اطلاعات خود جدول 1 یعنی جدول متناظر پاک شود (البته قبل از پاک شدن پیغامی مبنی بر اینکه پاک شود یا نه بدهد) .(شماره هر جدول در سلول بالا سمت راست آن نوشته شده است.) فایل پیوست کاملا گویاست رمز قفل 123

متشکرم از حسن نظرتان

[Amir Ghasemiyan]

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

[taocom52]

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

متشکرم

[Amir Ghasemiyan]

امیدوارم درست متوجه شده باشم

محدوده هایی که میخواین پاک بشن رو با دستور clearcontents محتوای اون سلول ها رو پاک میکنید

Sub ExcelIran()
Dim cel As Range
Dim TableNum As Integer
Lrow = Range("A1000").End(xlUp).Row
TableNum = Range("A" & Lrow).Value
For Each cel In Range("B" & Lrow & ":N" & Lrow)
    cleared = clearcontent(cel, TableNum)
Next cel
End Sub

Function clearcontent(cel As Range, TableNum As Integer)
Dim C As Range
Select Case TableNum
    Case 1
        For Each C In Range("B1:H14")
            If C.Value = cel.Value Then C.ClearContents
            Exit For
        Next C
    Case 2
        For Each C In Range("J1:P14")
            If C.Value = cel.Value Then C.ClearContents
            Exit For
        Next C
    Case 3
        For Each C In Range("R1:X14")
            If C.Value = cel.Value Then C.ClearContents
            Exit For
        Next C
End Select

End Function

[taocom52]

سلام ممنوع از زحمتی که کشیدید نمیدونم این کد رو خودتون امتحان کردید یا نه متاسفانه من نتونستم run کنم اگر ممکنه در همون فایل پیوست که براتون ارسال کردم کدتان را در ادامه ماکروی بنده وارد کنید و یک بار تست بفرمایید متشکرم

[Amir Ghasemiyan]

سلام دوست عزیز
این کد نمونس. باید برای حالت خودتون خصوصی سازیش کنید
البته کامل هم نیست. چون شما خودتون vba بلدین من دیگه در حد نیاز براتون نوشتم. بقیش با خودتون

[taocom52]

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

[Amir Ghasemiyan]

بفرمایید این کد رو تست کنید
قفل شیت رو هم غیر فعال کنید لطفا

Sub ExcelIran()
Dim cel As Range
Dim TableNum As Integer
Lrow = Range("A1000").End(xlUp).Row
Frow = Range("A" & Lrow).End(xlUp).Row + 1
For i = Lrow To Frow Step -1
    TableNum = Range("A" & i).Value
    For Each cel In Range("B" & Lrow & ":N" & Lrow)
        cleared = clearcontent(cel.Text, TableNum)
    Next cel
    Rows(i & ":" & i).ClearContents
Next i
End Sub


Function clearcontent(cel, TableNum As Integer)
Dim C As Range
Select Case TableNum
    Case 1
        For Each C In Range("B1:H14")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
    Case 2
        For Each C In Range("J1:P14")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
    Case 3
        For Each C In Range("R1:X14")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
End Select
End Function

[taocom52]

ممنون مهندس ، عمل کرد فقط برعکس عمل میکنه ، یعنی بجای محتوای داخل جداول (سلولهایی که قفل نیستند) ، خود سطرها را پاک میکنه ، همون سطرهایی که شمارشونو با قرمز نشون دادم ، سطرها نباید پاک بشن محتوای سلولهای غیر قفل داخل جدولهای متناظر بایستی پاک بشوند. ممنون

[Amir Ghasemiyan]

ممنون مهندس ، عمل کرد فقط برعکس عمل میکنه ، یعنی بجای محتوای داخل جداول (سلولهایی که قفل نیستند) ، خود سطرها را پاک میکنه ، همون سطرهایی که شمارشونو با قرمز نشون دادم ، سطرها نباید پاک بشن محتوای سلولهای غیر قفل داخل جدولهای متناظر بایستی پاک بشوند. ممنون

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

Rows(i & ":" & i).ClearContents

درضمن شما در ردیف هایی که قرمز هست سلول مرج شده استفاده کردین که نباید استفاده بشه

[taocom52]

سلام کد گفته شده را حذف کردم و سطرهای اعداد قرمز پاک نشد ولی همچنان محتوای جدول متناظر اعداد قرمز پاک نمیشوند البته کد خطا هم نمیدهد اما عملی هم صورت نمیگیرد ، این را هم بگویم که آدرس شماره های قرمز و جدولها همیشه ثابت است و تغییری نخواهد کرد.
تنها چیزی که خواسته بنده هست این است که وقتی عدد قرمز را انتخاب کردم با اجرای ماکرو جدول متناظرش پاک شود (سلولهای غیر قفل جدول) متشکرم

[Amir Ghasemiyan]

سلام دوست عزیز
نمیدونم چرا کدهای من این شکلی شده بود. یکم مشکل داشت کدها. ببخشید
این که گفتین محدوده ثابته و تغییر نمیکنه کار منو راحت کرد. یکسری کدها که برای داینامیک کردن محدوده استفاده کرده بودم حذف شد
این کد دیگه کار میکنه. تست کردم چند بار

Sub ExcelIran()
ActiveSheet.Unprotect "123"
Dim cel As Range
Dim TableNum As Integer
For i = 19 To 21
    TableNum = Range("A" & i).Value
    For Each cel In Range("B" & i & ":N" & i)
        cleared = clearcontent(cel.Value, TableNum)
    Next cel
Next i
ActiveSheet.Protect "123"
End Sub




Function clearcontent(cel, TableNum As Integer)
Dim C As Range
Select Case TableNum
    Case 1
        For Each C In Range("B1:H14")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
    Case 2
        For Each C In Range("J1:P14")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
    Case 3
        For Each C In Range("R1:X14")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
End Select
End Function

[taocom52]

ممنون مهندس کارکرد ولی اینبار هم همه جدولها را پاک میکند یعنی براش مهم نیست 1 قرمز را انتخاب کردی یا 3 یا 2 به هر حال همه را یکجا پاک میکند ، من محدوده ها پاک شونده را در جداول تغییر دام (در کد شما ) تا فقط سلولهای غیر قفل را پاک کندو آنها را رنگی کردم تا تست راحت بشه اگه امکان داره این فایل را که براتون میفرستم تست بفرمایید متشکرم خیلی زحمت دادم

[Amir Ghasemiyan]

یک تغییر جزئی دادم.
شما مثلا میخواین جدول یک رو حذف کنید. خونه قرمز رنگ شماره یک رو انتخاب میکنید و دکمه excel iran رو میزنید. و اطلاعات جدول یک حذف میشه

Sub ExcelIran()
ActiveSheet.Unprotect "123"
Dim cel As Range
Dim TableNum As Integer
i = ActiveCell.Row
If i <= 21 And i >= 19 Then
    TableNum = Range("A" & i).Value
    For Each cel In Range("B" & i & ":N" & i)
        cleared = clearcontent(cel.Value, TableNum)
    Next cel
End If
ActiveSheet.Protect "123"
End Sub
Function clearcontent(cel, TableNum As Integer)
Dim C As Range
Select Case TableNum
    Case 1
        For Each C In Range("c6,d9,f7,f10,f3,g4,g7")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
    Case 2
        For Each C In Range("k5,l12,n8,o10,p6")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
    Case 3
        For Each C In Range("r8,s8,t3,t10,v7,w10,x10")
            If C.Value = cel Then
                C.ClearContents
                Exit For
            End If
        Next C
End Select
End Function

[taocom52]

متشكرم كاركرد عالی بود راستی آقای مهندس چطوری میتونم باهاتون تماس بگیرم پروژه ای هست که احتمالا نیاز به همکاری تان داشته باشم ایمیل و تلفن بنده 09148126073 taocom52@gmail.com

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