آموزش ایجاد دیتا ولیدیشن با قابلیت سورت اطلاعات و افزودن دیتا از طریق دیتا ولیدیشن

[mokaram]

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

3544

اما در این آموزش قصد داریم که اطلاعات جدید را بشه از طریق خود دیتا ولیدیشن وارد لیست کرد و هم چنین اطلاعات بر اساس حروف الفبا مرتب بشن پس با ما همراه باشید
ابتدا دو تا شیت به نام های Data و List ایجاد می کنیم در شیت List در ستون B شروع به وارد کردن اطلاعات مورد نظر می کنیم و برای نامگذاری این محدوده ( ستون B) به صورت داینامیک به شکل زیر عمل می کنیم:
Formulas> Defined Names > name Manger
سپس new را زده و نام مورد نظر را در قسمت name می نویسیم. در قسمت Refer to فرمول زیر را درج می کنیم

=OFFSET(List!$B$1,0,0,COUNTA(List!$B:$B),1)
برای آگاهی از عمکرد تابع Offset به لینک زیر مراجعه کنید
http://forum.exceliran.com/showthread.php?t=2704
به شیت Data رفته و برای مثال در خانه B2 قرار گرفته و مانند تصویر بالا سورس city را از طریق گزینه List ایجاد می کنیم
نکته : برای اینکه بتوانیم اطلاعات را از طریق دیتا ولیدیشن وارد سورس اصلی بکنیم مانند تصویر زیر عمل نمایید

3545


حال نوبت به کدنویسی در محیط VBA میرسد بر روی شیت List راست کلیک کرده و گزینه View Code را انتخاب می کنیم و در ایونت ورک شیت کد زیر را می نویسیم:
3546
3547



Private Sub Worksheet_Change(ByVal Target As Range)
Columns(Target.Column).Sort _
Key1:=Cells(1, Target.Column), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub
از تب دولوپر ایتم کمبو باکس را از قسمت ActiveX Control برمی گزینیم و بر روی یکی از سلولهایی که دیتا ولیدیشین بر روی آن تعریف شده می کشیم
هم چنین کدهای زیر را نیز در ایونت ورک شیت Data وارد می کنیم:


Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim strMsg As String
Dim lRsp As Long
strMsg = "Add this item to the list?"

If Target.Count > 1 Then Exit Sub
Set ws = Worksheets("List")

If Target.Row > 1 Then
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngDV Is Nothing Then Exit Sub

If Intersect(Target, rngDV) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub

str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
On Error Resume Next
Set rng = ws.Range(str)
On Error GoTo 0
If rng Is Nothing Then Exit Sub

If Application.WorksheetFunction _
.CountIf(rng, Target.Value) Then
Exit Sub
Else
lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?")
If lRsp = vbYes Then
i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
ws.Cells(i, rng.Column).Value = Target.Value
rng.Sort Key1:=ws.Cells(1, rng.Column), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End If

End If

End Sub

Private Sub TempCombo_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)

On Error Resume Next
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim strMsg As String
Dim lRsp As Long
Dim c As Range
strMsg = "Add this item to the list?"

Set ws = Worksheets("List")
Set c = ActiveCell

str = c.Validation.Formula1
str = Right(str, Len(str) - 1)
On Error Resume Next
Set rng = ws.Range(str)
On Error GoTo 0
If rng Is Nothing Then Exit Sub

'Hide combo box and move to next cell on Enter and Tab
Select Case KeyCode
Case 9
c.Offset(0, 1).Activate
If c.Value = "" Then Exit Sub

If Application.WorksheetFunction _
.CountIf(rng, c.Value) Then
Exit Sub
Else
lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?")
If lRsp = vbYes Then
i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
ws.Cells(i, rng.Column).Value = c.Value
rng.Sort Key1:=ws.Cells(1, rng.Column), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End If

Case 13
c.Offset(1, 0).Activate
If c.Value = "" Then Exit Sub
If Application.WorksheetFunction _
.CountIf(rng, c.Value) Then
Exit Sub
Else
lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?")
If lRsp = vbYes Then
i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
ws.Cells(i, rng.Column).Value = c.Value
rng.Sort Key1:=ws.Cells(1, rng.Column), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End If
Case Else
'do nothing
End Select

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Dim rng As Range
Dim i As Integer
Dim strMsg As String
Dim lRsp As Long
Set ws = ActiveSheet
Set wsList = Sheets("List")
Set cboTemp = ws.OLEObjects("TempCombo")
strMsg = "Add this item to the list?"

If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
With cboTemp
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With

cboTemp.Activate
End If

exitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
errHandler:
Resume exitHandler

End Sub






امیدوارم مورد توجهتون قرار گرفته باشه

[misammisam]

سلام
دستت درد نكنه ، ولي من هر چي فكر كردم اين به چه دردي ، بجز يه تمرين براي كد نويسي ميخوره .
چون مميزي ليست رو از بين ميبره و شما هر چي بخوايد تو سلها مينويسيد و اگر غرض راحتتر كردن تايپ با ليست كردن نوشته هاي قبلي باشه ، خوب ميتونن با زدن كليد( Alt + كليد جهت پايين ) ، همين ليست باز ميشه .
تشكر

[ieumts]

با سلام
ممنون از مطلب جالبتون
بنظر من راه ساده تری هم بغیر از برنامه نویسی هس.
داده هامون رو بصورت format as table در بیاریم
از طریق تابع cell و زیربخش address و با ترکیب تابع counta، آدرس محدوده ای که توش داده وجود داره رو توی یک سلول بنویسیم.
اون وقت توی data validation به کمک تابع indirect لیست رو ازون محدوده بگیریم
(دلیل table کردن اینه که لیست بطور اتومات بروز بشه)

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

با درود
خب بریم سر قضیه جناب میثم خان گل - اینکه Alt+Down key رو بزنیم که فقط تا اونجایی که من ذهنم یاری میده جایی هستش که اطلاعات زیر یه ستون باشن . یعنی نمیشه این کلید رو برای یه ستون تو یه شیت دیگه به کار برد و اگر میشه م بلد نیستم . مرتب کردن بر اساس حروف الفبا هم که که نمیشه کتمانش کرد خیلی جا ها حتی تو فرمول نویسیا بدردمون میخوره در کل کار با داده های سورت شده خیلی اسونتره ( یه نمونش Datavalidation های وابسته به هم هستش که حالا به وقتش یه نمونه از سورت شدن ستون رو که مهمه با هم برسی میکنیم ) - دیتا ولیدیشنی که خاصیت پویا داشته باشه رو هیچ کس نمیتونه کتمانش کنه و همچنین اگر خاصیت یونیک شدن بهش اظافه شه . یه سری ما اشتباهات تایپی تو فرمول نویسی ها میکنیم که راحت رفع میشه با این مورد نمونه بارزش همون ی و ک ............. که میدونم اونم راه داره اما خب بلاخره هست دیگه

[Amir Ghasemiyan]

به شیت Data رفته و برای مثال در خانه B2 قرار گرفته و مانند تصویر بالا سورس city را از طریق گزینه List ایجاد می کنیم
نکته : برای اینکه بتوانیم اطلاعات را از طریق دیتا ولیدیشن وارد سورس اصلی بکنیم مانند تصویر زیر عمل نمایید

3545




هم چنین کدهای زیر را نیز در ایونت ورک شیت Data وارد می کنیم:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range

If Target.Count > 1 Then Exit Sub
Set ws = Worksheets("List")

If Target.Row > 1 Then
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngDV Is Nothing Then Exit Sub

If Intersect(Target, rngDV) Is Nothing Then Exit Sub

str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
On Error Resume Next
Set rng = ws.Range(str)
On Error GoTo 0
If rng Is Nothing Then Exit Sub

If Application.WorksheetFunction _
.CountIf(rng, Target.Value) Then
Exit Sub
Else
i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
ws.Cells(i, rng.Column).Value = Target.Value
rng.Sort Key1:=ws.Cells(1, rng.Column), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If

End If

End Sub
امیدوارم مورد توجهتون قرار گرفته باشه

ممنون عزيز. ولي من اين دو قسمت رو متوجه نشدم.
مخصوصا كدي كه تو شيت data نوشتي. كارش چيه؟

[misammisam]

با درود
خب بریم سر قضیه جناب میثم خان گل - اینکه Alt+Down key رو بزنیم که فقط تا اونجایی که من ذهنم یاری میده جایی هستش که اطلاعات زیر یه ستون باشن . یعنی نمیشه این کلید رو برای یه ستون تو یه شیت دیگه به کار برد و اگر میشه م بلد نیستم . مرتب کردن بر اساس حروف الفبا هم که که نمیشه کتمانش کرد خیلی جا ها حتی تو فرمول نویسیا بدردمون میخوره در کل کار با داده های سورت شده خیلی اسونتره ( یه نمونش Datavalidation های وابسته به هم هستش که حالا به وقتش یه نمونه از سورت شدن ستون رو که مهمه با هم برسی میکنیم ) - دیتا ولیدیشنی که خاصیت پویا داشته باشه رو هیچ کس نمیتونه کتمانش کنه و همچنین اگر خاصیت یونیک شدن بهش اظافه شه . یه سری ما اشتباهات تایپی تو فرمول نویسی ها میکنیم که راحت رفع میشه با این مورد نمونه بارزش همون ی و ک ............. که میدونم اونم راه داره اما خب بلاخره هست دیگه
بله درسته ، سورت شدنش خيلي خوبه كه به اين دقت نكرده بودم .
نكته هاي Datavalidation های وابسته رو هم يه قصه شب براش بزاري زودتر خيلي خوبه .
شبا ديگه قصه نميگي ، منم مجبورم برم ساعت 10 لالايي شبكه پويارو نگاه كنم تا خوابم ببره :bigsmileB:

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

با درود
چشم حتما - یه داستان خوب میزارم تو این زمیته

[Amir Ghasemiyan]

با درود
چشم حتما - یه داستان خوب میزارم تو این زمیته

بي زحمت داستانش عشقولانه باشه. دوست دارم از اينا :rolleyes:

[mokaram]

پست اول آپدیت شد (کدهای شیت Data کاملتر شد )

[حسینعلی]

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