کپی کردن یک رنج خاص از اعداد

[khorasan66]

با سلام خدمت تمامی اساتید :
در ستون A رنج A4:A30 مقادیر مابین 1000 تا 1500 درج شده اند
دستوری را نیاز دارم که تا 10 عدد از این رنج را که مساوی و یا بزرگتر از 1300 و مساوی و کوچک تر از 1500 میباشند را در صورت موجود بودن کپی نمودن و زیر هم مثلا از سلول A41:A50 جایگزین نماید .
ضمناً اگر تعداد این مقادیر معین شده ( مساوی و یا بزرگتر از 1300 و مساوی و کوچک تر از 1500 ) در رنج A4:A30 از 10 تا بیشتر بود پیام داده و کار متوقف شود .
با تشکر در صورت امکان با فایل نمونه پاسخ داده شود

[امين اسماعيلي]

RE: کپی کردن یک رنج خاص از اعداد

با درود
من کارتون رو انجام دادم به این نحو که ابتدا هر چی با این شرط که گفتین رو پیدا کنه و در شیت 2
کپی کنه و اگر که بیش از 10 تا بود بقیشو پاک کنه . اینکه اگر بیش از 10 تا بود متوقف بشه و پیغامم بده با یه فرمول ساده و مسیج باکس راحته .


حالا یه سوال دارم

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

من خودم گفتم که بیش از 10 تا رو پاک کنه. ولی کاره شما که ساده تره.

منتطر جواب میمونم. دوستان هم کمکی به این بنده حقیر بکنن جای دوری نمیره
الان ساعت 1.5 شبه . که کاره دوستمون رو هم با حلقه for و هم auto filter به نحوی که اصلا معلوم نیست که autofilter انجام شد . گاهی به هم فکری شما هم نیاز دارم
هر چند که این مسائل برای بسیاری از دوستان سادست

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

[khorasan66]

RE: کپی کردن یک رنج خاص از اعداد

با سلام و تشکر
اگر در این رنج یعنی a4:a30 تعداد اعداد خارج از شرط بیشتر از 10 تا باشد باید به کاربر هشدار بدهد تا تعداد این اعداد را به صورت دستی اصلاح نماید .
ضمناً من هیچ دستور و یا فایل نمونه را دریافت نکردم .
با تشکر
من تا اینجا پیش رفتم بقیه اش کمک می خواهم
Sub Copy_05()
Dim d
For Each d In Sheet5.Range("a4:a30")
If d >= 1300 And d <= 1500 Then
؟؟؟؟؟؟؟؟
؟؟؟؟؟؟؟؟
End If
Next
End Sub

[khakzad]

RE: کپی کردن یک رنج خاص از اعداد

Dim d,i
i=0
For Each d In Sheet5.Range("a4:a30")
If d >= 1300 And d <= 1500 Then i=i+1
if i<10 go to 10
next d
else
msgbox "adad kharej az shart hastand"
exit sub
end if
[hr]
سلام
این کد خدمت شما
امیدوارم ج بده
فقط قبل از next d عدد 10 رو با یک space بعدش تایپ کنید.من نتونستم اینجا درست نشون بدم

[امين اسماعيلي]

RE: کپی کردن یک رنج خاص از اعداد

با درود

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

[امين اسماعيلي]

RE: کپی کردن یک رنج خاص از اعداد

با درود

من روی او.ن موضوع که گفتین اگر بیش از 10 تا توی محدوده باشه پیام بده کار کردم.

خوب به این صورت که در رنج A1 سر تیتر Number رو بنویسین و زیر اون هر چقدر که خواستین عدد بزارین. 2- در رنج C1 بنویسین result یا هرچی( نتیجه) یعنی میخوایم یه دکمه بزاریم و توی ستون A بگرده هذچی که بود و با شرایط ما جور در میومد رو بیاره تو ستون C از C2 به بعد بزاره و اون شرایطی رو هم که گفتین برسی کنه. خوب اگه کارای بالا رو انجام دادین یه CommandButton توی شیت 1 که داریم اونجا برسی میکنیم بزارین و روش دبل کلیک کنین تا به صفحه کد منتقل بشین و کد های زیر رو براش وترد کنین


[undefined=undefined]


Private Sub CommandButton1_Click()

With Application
' Turn off screen updating to increase performance
.ScreenUpdating = False
End With
Dim c
Dim rngToCheck As Range
Dim LastRow, lastrow2 As Long
With Sheet1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastrow2 = .Cells(.Rows.Count, "C").End(xlDown).Row
End With
Sheet1.Range("C2:C" & lastrow2) = ""

Set rngToCheck = Sheet1.Range("A2:A" & LastRow)

For Each c In rngToCheck
If c.Value <> "" Then
If c.Value >= 1300 And c.Value <= 1500 Then
Sheet1.Range("C1").Offset(Application.WorksheetFun ction.CountA(Sheet1.Range("C1:C10000")), 0) = c.Value
End If
End If
Next c
If Sheet1.Range("C12").Value <> "" Then
MsgBox " your Aria is more than 10 and all clear " & vbNewLine & "please Currect your range", vbCritical, "Error more 10"
Sheet1.Range("C2:C" & lastrow2) = ""

End If
End Sub

خوب حالا چک کنین.
نمیدونم چرا وقتی کد حا رو کپی میکنیم تو تالار کجوکوله کپی میشن[hr]
یه قولی به یه نفر دادم ولی چون مجبورم نمونه فایل رو بزارم چون کدها بدجوری کجو کوله اینجا کپی شدن

لینک :

http://uplod.ir/lfuyqtno1g05/Copy_specific_range.xlsm.htm


از اینکه قولمونو مجبور شدیم بشکنیم از ...... معذرت میخوام .