با سلام
همونطور که می دونید یکی از راههای ایجاد دیتا ولیدیشن استفاده از لیست هست به طوری که اطلاعات لیست داخل دیتا ولیدیشن میاد. از ترتیب خاصی پیروی نمیکنه و برای افزودن اطلاعات به دیتا ولیدیشن ابتدا باید محدود لیست ما تغییر بکنه و بعد اون تغییرات در دیتا ولیدیشن بیاد
اما در این آموزش قصد داریم که اطلاعات جدید را بشه از طریق خود دیتا ولیدیشن وارد لیست کرد و هم چنین اطلاعات بر اساس حروف الفبا مرتب بشن پس با ما همراه باشید
ابتدا دو تا شیت به نام های Data و List ایجاد می کنیم در شیت List در ستون B شروع به وارد کردن اطلاعات مورد نظر می کنیم و برای نامگذاری این محدوده ( ستون B) به صورت داینامیک به شکل زیر عمل می کنیم:
Formulas> Defined Names > name Manger
سپس new را زده و نام مورد نظر را در قسمت name می نویسیم. در قسمت Refer to فرمول زیر را درج می کنیم
کد PHP:
=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 را انتخاب می کنیم و در ایونت ورک شیت کد زیر را می نویسیم:
کد PHP:
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 وارد می کنیم:
کد PHP:
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
امیدوارم مورد توجهتون قرار گرفته باشه
 |
اخطار: این یک موضوع قدیمی است
به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید. |
|
آموزش ایجاد دیتا ولیدیشن با قابلیت سورت اطلاعات و افزودن دیتا از طریق دیتا ولیدیشن
پاسخ با نقل قول
نوشته اصلی توسط M_R_M
علاقه مندی ها (Bookmarks)