SHARE
TWEET

Untitled

a guest Apr 25th, 2019 60 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. 'Option Explicit
  2.  
  3. Private Sub Lookup(ByVal Target As Range, ByVal ColNum As Integer, ByVal WS_DataBase As String)
  4.     Dim Found As Integer
  5.         Found = 0
  6.        
  7.     If ColNum = 1 Then
  8.         For i = 0 To Application.WorksheetFunction.CountA(Worksheets(WS_DataBase).Range("A:A")) - 2
  9.             If Worksheets(WS_DataBase).Range("A2").Offset(i, 0).Value = Target.Value Then
  10.                 Target.Offset(0, 1).Value = Worksheets(WS_DataBase).Range("A2").Offset(i, 1).Value
  11.                 Target.Offset(0, 2).Value = Worksheets(WS_DataBase).Range("A2").Offset(i, 2).Value
  12.                 Target.Offset(0, 3).Value = Worksheets(WS_DataBase).Range("A2").Offset(i, 3).Value
  13.                 Target.Offset(0, 4).Value = Worksheets(WS_DataBase).Range("A2").Offset(i, 4).Value
  14.                 Found = Found + 1
  15.             End If
  16.         Next i
  17.     End If
  18.        
  19.     If ColNum = 3 Then
  20.         For i = 0 To Application.WorksheetFunction.CountA(Worksheets(WS_DataBase).Range("A:A"))
  21.             If Worksheets(WS_DataBase).Range("C2").Offset(i, 0).Value = Target.Value Then
  22.                 Target.Offset(0, -2).Value = Worksheets(WS_DataBase).Range("C2").Offset(i, -2).Value
  23.                 Target.Offset(0, -1).Value = Worksheets(WS_DataBase).Range("C2").Offset(i, -1).Value
  24.                 Target.Offset(0, 1).Value = Worksheets(WS_DataBase).Range("C2").Offset(i, 1).Value
  25.                 Target.Offset(0, 2).Value = Worksheets(WS_DataBase).Range("C2").Offset(i, 2).Value
  26.                 Found = Found + 1
  27.             End If
  28.         Next i
  29.     End If
  30.        
  31.     If Found = 0 Then
  32.         MsgBox ("Nie znaleziono")
  33.         Application.Undo
  34.     ElseIf Found > 1 Then
  35.         MsgBox (Found & " zduplikowane pozycje")
  36.     End If
  37. End Sub
  38.  
  39. Private Sub Worksheet_Change(ByVal Target As Range)
  40.     Application.EnableEvents = False
  41.    
  42.     Dim WS_DataBase As String
  43.         WS_DataBase = "B"
  44. 'SIZE
  45.     If Selection.Count > 1 Then
  46.         Application.Undo
  47.         Application.EnableEvents = True
  48.         MsgBox ("Zaznaczono więcej niż jedną komórkę")
  49.         Exit Sub
  50.     End If
  51.  
  52. 'CLEAR
  53.     If Target.Value = "" And Target.Row > 1 Then
  54.         Target.Rows.EntireRow.ClearContents
  55.         Application.EnableEvents = True
  56.         Exit Sub
  57.     End If
  58.    
  59. 'LOOKUP
  60.     If Target.Row > 1 Then
  61.         If (Target.Column = 1 Or Target.Column = 3) And Target.Value <> "" Then
  62.             Call Lookup(Target, Target.Column, WS_DataBase)
  63.         Else
  64.         Application.Undo
  65.         End If
  66.     End If
  67.    
  68.     Application.EnableEvents = True
  69. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top