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

[mokaram]

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

اما در این آموزش قصد داریم که اطلاعات جدید را بشه از طریق خود دیتا ولیدیشن وارد لیست کرد و هم چنین اطلاعات بر اساس حروف الفبا مرتب بشن پس با ما همراه باشید
ابتدا دو تا شیت به نام های 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 ایجاد می کنیم
نکته : برای اینکه بتوانیم اطلاعات را از طریق دیتا ولیدیشن وارد سورس اصلی بکنیم مانند تصویر زیر عمل نمایید

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

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 ایجاد می کنیم
نکته : برای اینکه بتوانیم اطلاعات را از طریق دیتا ولیدیشن وارد سورس اصلی بکنیم مانند تصویر زیر عمل نمایید

[ATTACH=CONFIG]3545[/ATTACH]

---

هم چنین کدهای زیر را نیز در ایونت ورک شیت 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]

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

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

[mokaram]

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

[حسینعلی]

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