هشدار خالی بودن سلول در هنگام کپی 2

**Amir Mohsenpour** · 2017/01/09, 16:07

Option Explicit

Sub Copy2TOLID110()
Dim k As Integer
If WorksheetFunction.CountA(Worksheets("cal").Range(" b3:h3")) > 0 Then
k = Sheets("cal").Range("a3").Value
Worksheets("cal").Range("b3:h3").Copy
Worksheets("cal2").Cells(k, 2).PasteSpecial xlPasteValues
Else: MsgBox "no data"

End If

Worksheets("A").Select
End Sub

**ahmada1983** · 2017/01/09, 16:28

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

**amir_ts** · 2017/01/09, 18:15

امتحان کنید...

کد:

[LEFT]
Sub Copy2TOLID110()
Dim k As Integer
If WorksheetFunction.CountIf(Worksheets("cal").Range("b3:h3"), 0) = 0 Then
                   k = Sheets("cal").Range("a3").Value
                    Worksheets("cal").Range("b3:h3").Copy
                    Worksheets("cal2").Cells(k, 1).PasteSpecial xlPasteValues
Else: MsgBox "no data"
End If
Worksheets("A").Select
End Sub
[/LEFT]

فایل های پیوست شده

111.rar (17.5 کیلو بایت, مشاهدات 8)

**Amir Mohsenpour** · 2017/01/09, 23:43

نوشته اصلی توسط ahmada1983

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

باسلام و عرض ادب
با توجه به نوشتن کانت a بجای کانت if حتما جواب میده لطفا امتحان کنید و نتیجه رو اعلام بفرمایین
بااحترام

**Amir Mohsenpour** · 2017/01/09, 23:48

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

**ahmada1983** · 2017/01/10, 08:31

واقعا ممنون فقط یک مشکل کوچیک اینکه چرا وقتی کپی انجام می شه توی cel2 از ستون A شروع میکنه و کپی می کنه مگه ما شروع محدوده کپی رو از b ندادیم

**Amir Mohsenpour** · 2017/01/10, 08:44

Option Explicit

Sub Copy2TOLID110()
Dim k As Integer
If WorksheetFunction.CountBlank(Worksheets("cal").Ran ge("b3:h3")) = 0 Then
k = Sheets("cal").Range("a3").Value
Worksheets("cal").Range("b3:h3").Copy
Worksheets("cal2").Cells(k, 2).PasteSpecial xlPasteValues
Else: MsgBox "no data"

End If

Worksheets("A").Select
End Sub

شروع محدوده کپی B3 هستش اگه محدوده دیگری مدنظرتونه خودتون میتونین Alt+F11 رو بزنین و ادیت کنید

**ahmada1983** · 2017/01/10, 08:52

مشکل حل شد
Worksheets("cal2").Cells(k, 1).PasteSpecial xlPasteValues
بجای (k,1) زدم(k,2)

**Amir Mohsenpour** · 2017/01/10, 08:54

منم ک همینو براتون نوشتم ...ولی موفق باشید خوشحالم ک مشکلتون حل شد
از Amir_ts عزیز هم ممنون

**ahmada1983** · 2017/01/10, 09:00

من فرمول رو یکم تغییر دادم که اسم شیت رو از سلول a1 بگیره و جواب درست بود ولی وقتی مقدار k رو تغییر دادم ERROR می ده مشکل از کجاست
Sub Copy2TOLID110()
Dim x As String
Dim k As Integer
If WorksheetFunction.CountIf(Worksheets("cal").Range( "b3:h3"), 0) = 0 Then
x = Sheets("cal").Range("a2").Value
k = Count(Worksheets(x).Range("a:a"))
Worksheets("cal").Range("b3:h3").Copy
Worksheets(x).Cells(k, 2).PasteSpecial xlPasteValues
Else: MsgBox "no data"

End If
Worksheets("A").Select
End Sub

**ahmada1983** · 2017/01/10, 09:02

ممنون فکر کنم پست شما چند ثانیه زودتر اومد . . .

**Amir Mohsenpour** · 2017/01/10, 09:12

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

**ahmada1983** · 2017/01/10, 09:29

فایل همونه که خودتون فرستادین فقط من یکم تغییر توی کداش دادم و می خوام در نهایت به اینجا برسم که برای انجام کپی
1-اسم شیت رو از یک سلول توی Cal بگیره
2-کپی در اولین ردیف خالی شیت مورد نظر انجام بشه
3- شماره ردیف هم در اولین سلول قرار داده بشه بطوری که اگه ردیفی حذف بشه شماره ها آپدیت بشن
4- جدا از کپی در شیت مورد نظر همه اطلاعات در یک شیت جداگانه ذخیره بشن(اطلاعاتی که در شیت های مختلف ذخیره می شن تجمیع بشن توی مثلا شیت Totall)
می دونم خیلی طولانی شد ببخشید

دو مورد اول رو حل کردم
فقط مونده مورد 3
4 هم که زیاد سخت نیست