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

[Lean 56,968]

با سلام

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

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

ابتدا دو تا شیت به نام های Data و List ایجاد می کنیم در شیت List در ستون B شروع به وارد کردن اطلاعات مورد نظر می کنیم و برای نامگذاری این محدوده ( ستون B) به صورت داینامیک به شکل زیر عمل می کنیم:

Formulas> Defined Names > name Manger

سپس new را زده و نام مورد نظر را در قسمت name می نویسیم. در قسمت Refer to فرمول زیر را درج می کنیم

برای مشاهده این محتوا لطفاً ثبت نام کنید یا وارد شوید.

• ورود
• یا
• ثبت نام

 

برای آگاهی از عمکرد تابع Offset به لینک زیر مراجعه کنید

برای مشاهده این محتوا لطفاً ثبت نام کنید یا وارد شوید.

• ورود
• یا
• ثبت نام

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

نکته : برای اینکه بتوانیم اطلاعات را از طریق دیتا ولیدیشن وارد سورس اصلی بکنیم مانند تصویر زیر عمل نمایید

 

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

 

 

 

 

برای مشاهده این محتوا لطفاً ثبت نام کنید یا وارد شوید.

• ورود
• یا
• ثبت نام

 

از تب دولوپر ایتم کمبو باکس را از قسمت 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

 

برای مشاهده این محتوا لطفاً ثبت نام کنید یا وارد شوید.

• ورود
• یا
• ثبت نام

برای مشاهده این محتوا لطفاً ثبت نام کنید یا وارد شوید.

• ورود
• یا
• ثبت نام