ماکرو برای پاک کردن هوشمند

[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

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

[Amir Ghasemiyan]

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

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

[taocom52]

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

[Amir Ghasemiyan]

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

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

[taocom52]

نه مهندس من اونو اصلا پاک کردم (اون ماله وقتی که در ms box کلمه no را انتخاب میکنیم یعنی کاری انجام نده و a329 را انتخاب کنه ) بعبارتی انتخاب سلولی که اول انجام دادیم بقوت خودش باقی باشه مگر اینکه تصور بنده غلط باشه ، یعنی بعد از عملیات ماکرو selaction دیگه اون سلولی نباشه که اول انتخاب کردیم ، در این صورت به کمک شما باز نیاز دارم

[Amir Ghasemiyan]

نه مهندس من اونو اصلا پاک کردم (اون ماله وقتی که در ms box کلمه no را انتخاب میکنیم یعنی کاری انجام نده و a329 را انتخاب کنه ) بعبارتی انتخاب سلولی که اول انجام دادیم بقوت خودش باقی باشه مگر اینکه تصور بنده غلط باشه ، یعنی بعد از عملیات ماکرو selaction دیگه اون سلولی نباشه که اول انتخاب کردیم ، در این صورت به کمک شما باز نیاز دارم

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

[taocom52]

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

به هرحال ببخشید که منظورم براتون خیلی واضح بیان نشده بود متشکرم

[Amir Ghasemiyan]

درسته. حالا کامل متوجه شدم
کد macro1 که مربوط به بایگانی هست رو اینطوری اصلاح کنید:


Sub Macro1()
Application.ScreenUpdating = False
Dim C
Dim i
x = MsgBox("áØÝÇ ãØãÆä ÔæíÏ ˜å ÔãÇÑå Óåã ÑÇ ÏÑ ÓÊæä ÓÈÒ Ñä äÔÇä ÏÇÏå ÔÏå ÇäÊÎÇÈ ˜ÑÏå ÇíÏ ÏÑ ÛíÑ ÇíäÕæÑÊ Óåã ÔãÇ ÏÑÓÊ ÈÇíÇäí äÎæÇåÏ ÔÏ æ ÇÔ˜ÇáÇÊí ÏÑ ãÍÇÓÈÇÊ ÑíÇáí íÔ ÎæÇåÏ ÂãÏ", vbYesNoCancel, "massage box")
If x = vbYes Then
For Each C In Sheet2.Range("a1:a10000")
If C = Empty Then
For i = 0 To 14
C.Offset(0, i) = Selection.Offset(0, i)
Next i
ExcelIran
Exit Sub
End If
Next


ElseIf x = vbNo Then
Range("a329").Select


End If


Application.ScreenUpdating = True
End Sub




کدهایی هم که قبلا خدمتتون دادم به این صورت اصلاح کنید:


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 Sheet1.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("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]

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