Zdarvim vsechny resim jeden problem kde bych potreboval aktualizovat sloupcec s materialem ve na liste data. Logika by mela porovnat ktere materialy chybi oproti listu zdroj a tyto chybejici artikly pridat nakonec pod stavajici materialy na liste data. Kdyby nekdo dokazal budu rad . Příloha 
Ale otestujte si to, príliš pozornosti som tomu nevenoval 
Sub Aktualizuj()
Dim colData As New Collection, D As Long, R As Long, arrZdroj(), arrData(), Pocet As Long
With wsData
D = .Cells(Rows.Count, 5).End(xlUp).Row - 3
If D = 1 Then Exit Sub
ReDim arrData(1 To D, 1 To 1)
If D = 1 Then arrData(1, 1) = .Cells(4, 5).Value Else arrData = .Cells(4, 5).Resize(D).Value
End With
On Error Resume Next
For R = 1 To D
colData.Add arrData(R, 1), CStr(arrData(R, 1))
Next R
On Error GoTo 0
With wsZdroj
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 1 Then Exit Sub
ReDim arrZdroj(1 To R, 1 To 1)
If R = 1 Then arrZdroj(1, 1) = .Cells(2, 1).Value Else arrZdroj = .Cells(2, 1).Resize(R).Value
End With
Erase arrData
On Error Resume Next
For R = 1 To R
colData.Add arrZdroj(R, 1), CStr(arrZdroj(R, 1))
If Err.Number <> 0 Then
Err.Clear
Else
Pocet = Pocet + 1
ReDim Preserve arrData(1 To 1, 1 To Pocet)
arrData(1, Pocet) = arrZdroj(R, 1)
End If
Next R
On Error GoTo 0
If Pocet > 0 Then wsData.Cells(D + 4, 5).Resize(Pocet).Value = Application.Transpose(arrData)
End Sub
Sub Aktualizuj()
Dim colData As New Collection, D As Long, R As Long, arrZdroj(), arrData(), Pocet As Long
With wsData
D = .Cells(Rows.Count, 5).End(xlUp).Row - 3
If D = 1 Then Exit Sub
ReDim arrData(1 To D, 1 To 1)
If D = 1 Then arrData(1, 1) = .Cells(4, 5).Value Else arrData = .Cells(4, 5).Resize(D).Value
End With
On Error Resume Next
For R = 1 To D
colData.Add arrData(R, 1), CStr(arrData(R, 1))
Next R
On Error GoTo 0
With wsZdroj
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 1 Then Exit Sub
ReDim arrZdroj(1 To R, 1 To 1)
If R = 1 Then arrZdroj(1, 1) = .Cells(2, 1).Value Else arrZdroj = .Cells(2, 1).Resize(R).Value
End With
Erase arrData
On Error Resume Next
For R = 1 To R
colData.Add arrZdroj(R, 1), CStr(arrZdroj(R, 1))
If Err.Number <> 0 Then
Err.Clear
Else
Pocet = Pocet + 1
ReDim Preserve arrData(1 To 1, 1 To Pocet)
arrData(1, Pocet) = arrZdroj(R, 1)
End If
Next R
On Error GoTo 0
If Pocet > 0 Then wsData.Cells(D + 4, 5).Resize(Pocet).Value = Application.Transpose(arrData)
End Sub
Příloha: 
42424_pridat-neexistujuce.zip (19kB, staženo 20x)
citovat42424_pridat-neexistujuce.zip (19kB, staženo 20x)
, když sem to dokončil tak mi kleklo PC a soubor se neuložil), tak přidávám i to své.
Díky moc za pomoc oboum.
\n
RSS nejnovější články