To nepôjde, musíte si urobiť zlučovaciu tabuľku...citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: ověření dat - seznam z výce zdrojů
MS Excel
Téma: ověření dat - seznam z výce zdrojů 
Zaslal/a Mell 26.6.2017 13:43
Ahoj pánové,
nejspíš to bude úplná banalita, která mi zkrátka nedochází nebo to seznam neumožnuje. Jde do seznamu v ověření dat zahrnout data z více zdrojů (listů). Resp. pokračovat při vybírání dat na dalším listě. viz. vzor, děkuji za pomoc a nezlobte se, že otravuji s takovou prkotinou.
Příloha: 
36734_vzor.xlsx (11kB, staženo 29x)
36734_vzor.xlsx (11kB, staženo 29x)pomocná tabulka pokulhává, protože se data ve zdroji 1 a 2 budou dynamicky měnit podle příbytků a úbytků. Resp. by to možná šlo, ale už by to nebyla jednoduchá pomocná tabulka.citovat
Napr. vzorec na 1000 riadkov.
Příloha: 36737_36734_vzor.xlsx (35kB, staženo 33x)
citovat36737_36734_vzor.xlsx (35kB, staženo 33x)Pridávam zoznam (Spoj) aktualizovaný pomocou Power Query ([aktualizovaný pri otvorení a každé 3 minúty] použiteľné od verzie 2010-doplnok, 2016-obsahuje).
Příloha: 36738_pq-vzor.xlsx (33kB, staženo 29x)
citovat36738_pq-vzor.xlsx (33kB, staženo 29x)(27.6.2017 3:18)#036739
Pridavam reseni makrem:
Option Explicit
Function LastUsedRow(ws As Worksheet, column As Long) As Long
LastUsedRow = ws.Cells(ws.Rows.Count, column).End(xlUp).Row
End Function
Sub SetValidation()
Dim RngSource As Range, rDV As Range, r As Range, csString As String, v As String
Dim c As Collection
Dim sDV As Worksheet, sH As Worksheet
Set sDV = ThisWorkbook.Sheets("výstup")
Set rDV = sDV.Range("A2:A50")
csString = ""
Set c = New Collection
'set zdroj1
Set sH = ThisWorkbook.Sheets("zdroj1")
Set RngSource = sH.Range("A2:A" & LastUsedRow(sH, 1))
On Error Resume Next
For Each r In RngSource
v = r.Value
If v <> "" Then
c.Add v, CStr(v)
If Err.Number = 0 Then
If csString = "" Then
csString = v
Else
csString = csString & "," & v
End If
Else
Err.Number = 0
End If
End If
Next r
On Error GoTo 0
'set zdroj2
Set sH = ThisWorkbook.Sheets("zdroj2")
Set RngSource = sH.Range("A2:A" & LastUsedRow(sH, 1))
On Error Resume Next
For Each r In RngSource
v = r.Value
If v <> "" Then
c.Add v, CStr(v)
If Err.Number = 0 Then
If csString = "" Then
csString = v
Else
csString = csString & "," & v
End If
Else
Err.Number = 0
End If
End If
Next r
On Error GoTo 0
'MsgBox csString
With rDV.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=csString
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
Set sH = Nothing
Set sDV = Nothing
Set RngSource = Nothing
Set rDV = Nothing
End Subcitovat
Option Explicit
Function LastUsedRow(ws As Worksheet, column As Long) As Long
LastUsedRow = ws.Cells(ws.Rows.Count, column).End(xlUp).Row
End Function
Sub SetValidation()
Dim RngSource As Range, rDV As Range, r As Range, csString As String, v As String
Dim c As Collection
Dim sDV As Worksheet, sH As Worksheet
Set sDV = ThisWorkbook.Sheets("výstup")
Set rDV = sDV.Range("A2:A50")
csString = ""
Set c = New Collection
'set zdroj1
Set sH = ThisWorkbook.Sheets("zdroj1")
Set RngSource = sH.Range("A2:A" & LastUsedRow(sH, 1))
On Error Resume Next
For Each r In RngSource
v = r.Value
If v <> "" Then
c.Add v, CStr(v)
If Err.Number = 0 Then
If csString = "" Then
csString = v
Else
csString = csString & "," & v
End If
Else
Err.Number = 0
End If
End If
Next r
On Error GoTo 0
'set zdroj2
Set sH = ThisWorkbook.Sheets("zdroj2")
Set RngSource = sH.Range("A2:A" & LastUsedRow(sH, 1))
On Error Resume Next
For Each r In RngSource
v = r.Value
If v <> "" Then
c.Add v, CStr(v)
If Err.Number = 0 Then
If csString = "" Then
csString = v
Else
csString = csString & "," & v
End If
Else
Err.Number = 0
End If
End If
Next r
On Error GoTo 0
'MsgBox csString
With rDV.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=csString
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
Set sH = Nothing
Set sDV = Nothing
Set RngSource = Nothing
Set rDV = Nothing
End Subcitovat
Mockrát pánové děkuji, že jste mi věnovali trocha prostoru. Během dne otestuji a dám vědět :) Ještě jednou děkuji!!!citovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články