[حل شده] درج کد پرسنلی و فراخوانی اطلاعات

[mohammad59]

سلام

وقت بخیر

کدی می خوام که اگه در سلول a1 شیت 1 کد پرسنل رو وارد کردم به صورت اتومات اطلاعات مربوط به این کد که در شیت 2 از A1تاH1 وارد شده را برام بیاره



با تشکر و سپاس

[amir_ts]

با سلام
با تابع vlookup به نتیجه میرسید فایل نمونه رو ملاحظه کنید.

[mohammad59]

ممنون دوست عزیز

فرمول رو بلدم
می خواستم همینو تو vba داشته باشم

[amir_ts]

فایل پیوست شد.

Cells(1, 2).Value = Application.WorksheetFunction.vlookup(Sheet1.Range("A1"), Sheet2.Range("A1:h1"), 2, False) 

[mohammad59]

بسیار سپاسگزارم

[mohammad59]

Private Sub ComboBox1_Click()
ComboBox1.Clear
With Sheet2.ComboBox1
.AddItem "ãÑÏ"
.AddItem "Òä"
End With
End Sub
وقتی انتخاب می کنم در سلولی که لینک کردم درج نمی شه یا سریع میاد میره

[amir_ts]

با سلام

[LEFT]
Private Sub CommandButton1_Click()
Sheet1.ComboBox1.Clear
ComboBox1.LinkedCell = "a1"
With Sheet1.ComboBox1
    .AddItem "Paris"
    .AddItem "New York"
    .AddItem "London"
End With
End Sub
[/LEFT]

[mohammad59]

سپاس برادر

[mohammad59]

سلام مجدد
ببخشید امکان داره بدون اجرای ماکرو وقتی کد پرسنلی رو تایپ کردی اتومات اطلاعات رو بیاره بدون اینکه نیاز باشه ماکرو رو اجرا کنی؟

[amir_ts]

ببخشید امکان داره بدون اجرای ماکرو وقتی کد پرسنلی رو تایپ کردی اتومات اطلاعات رو بیاره بدون اینکه نیاز باشه ماکرو رو اجرا کنی؟

با سلام
با ورود درست کد پرسنلی اطلاعات فراخوان میشود.

[LEFT]
Private Sub Worksheet_Change(ByVal Target As Range)
        If Not Intersect(Target, Me.Range("a1")) Is Nothing Then
    Call vlookup
         End If
End Sub
[/LEFT]

[mohammad59]

سلام بسیار سپاسگزارم

یه مورد دیگه اینکه و قتی این کد رو (ذخیره) اجرا می کنم با تاخیر زیاد ذخیره می کنه علتش چی می تونه باشه؟

Sub Save()
Application.Calculation = xlCalculationManual
Dim Rng1 As Range
If Range("h8:h10").Text = "" Then
MsgBox "لطفا موارد ستاره دار تکميل گردد "
Exit Sub
ElseIf Not IsNumeric(Range("h7").Text) Then
MsgBox "کد پرسنلي به صورت عدد وارد شود "
Exit Sub
End If
'Copy data from sheet2 sheet
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Sheets("sheet2").Select
Range("h7:h29").Select
Selection.Copy
Dim rngX As Range
Sheets("sheet2").Select
Set rngX = Worksheets("sheet3").Range("A1:A300").Find(Workshe ets("sheet2").Range("h7"), lookat:=xlPart)
If Not rngX Is Nothing Then
Sheets("sheet3").Select
Range(rngX.Address).Select
'Past data changes
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("sheet2").Select
Range("h7:h29").Select
Selection.ClearContents
Range("h7").Select
MsgBox "اطلاعات جديد ذخيره شد"
Else
Sheets("sheet3").Select
Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True
'ActiveSheet.Paste
ActiveCell.Offset(1).EntireRow.Insert
End If
Application.Calculation = xlCalculationAutomatic
End Sub

[amir_ts]

حقیقت تا حالا این مورد برام پیش نیومده ، دقیقا نمیدونم چه دلیلی میتونه داشته باشه اجازه بدید اساتید و مدیران عزیز این بخش نظرشون رو اعلام کنند.