V sesitech pok_dat a pok_file je predpokladno, ze ve 4. radku jsou hlavicky sloupcu a zaznamy zacinaji v 5. radku. Nutno dodrzet zejmena v cilovych souborech typu pok_file.xls, ktere jsou ciste datove bez procedur VBA.
Nize uvedenou proceduru vloz v editoru VBA do standardniho modulu v sesitu pok_dat.xls, volej z menu (nabidka Nastroje>Makro>Makra...>...) nebo klavesovou zkratkou.
Po spusteni je zobrazen pozadavek na vlozeni nazvu souboru typu pok_file.xls s prednastavenou cestou (tentyz adresar jako u pok_dat), muzes zapsat jinou.
Dale je zobrazen pozadavek na vlozeni jmena listu v souboru pok_file. Pokud budou mit tyto soubory pouze jeden list, uprav zmenou v zaremovani casti procedury (oznaceno v procedure, cast cilovy list).
Hodnoty Active number jsou prirazeny do vsech zaznamu, pro ktere byly nalezeny, tak jak jsi drive uvedl (30.7.).
Cilovy soubor je na konci procedury uzavren.
Kód: Vybrat vše
Option Explicit
Sub FindAndCopy()
' source
Dim SWsht As Worksheet, SBlk As Range, SCll As Range, STmp As String
' target
Dim TPathFile As String, TWbk As Workbook, TWshtN As String
Dim TWsht As Worksheet, TBlk As Range, TCll As Range
' support
Dim Tmp As String, Tmp090 As String, FrstAddr As String
' zdrojovy soubor a list
Set SWsht = Workbooks("pok_dat.xls").Worksheets("list1")
' zdrojovy blok pro hledane hodnoty, sloupec B:B, overeni pritomnosti dat
With SWsht
Set SBlk = .Range("b4:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
End With
If SBlk.Resize(1, 1).Offset(SBlk.Rows.Count - 1, 0).Value = vbNullString Then
MsgBox "Na listu: '" & SWsht.Name & "' nejsou data"
GoTo Err1
End If
' cilovy soubor:
TPathFile = Application.InputBox("Zadej disk, cestu a nazev ciloveho souboru" & vbCr & vbCr _
& "Vzor: Disk:\adresar\nazev.xls", Default:=Application.ActiveWorkbook.Path & "\", Type:=2)
If TPathFile = "False" Then Exit Sub ' storno vraci "False"
On Error Resume Next
Set TWbk = Workbooks.Open(TPathFile) ' otevrit
If Err.Number <> 0 Then
MsgBox "Chyba v zadani ciloveho souboru - disk|cesta|nazev:" & vbCr & vbCr & TPathFile
GoTo Err1
End If
' list v cilovem souboru:
''*je pouze jeden***********
' Set TWsht = TWbk.ActiveSheet
''*nutno vybrat z vice******
TWshtN = Application.InputBox("Zadej nazev ciloveho listu", Type:=2)
If TWshtN = "False" Then GoTo Err2
Set TWsht = TWbk.Worksheets(TWshtN)
If Err.Number <> 0 Then
MsgBox "List: '" & TWshtN & "' nebyl nalezen"
GoTo Err2
End If
''**************************
On Error GoTo 0
' cilovy blok, sloupec B:B, overeni pritomnosti dat
With TWsht
Set TBlk = .Range("b5:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
End With
If TBlk.Resize(1, 1).Offset(TBlk.Rows.Count - 1, 0).Value = vbNullString Then
MsgBox "Na listu: '" & TWsht.Name & "' nejsou data"
GoTo Err3
End If
' prochazet TBlk a hledat prislusnou hodnotu ve zdroji SBlk
Application.ScreenUpdating = False
Tmp = vbNullString ' vychozi hodnota pro docasne ulozeni TCll a hodnoty prave strany ze sloupce D:D
For Each TCll In TBlk.Cells
' prava strana ze sloupce D:D
Tmp090 = IIf(Len(TCll.Offset(0, 2).Value) = 13 And Right(TCll.Offset(0, 2).Value, 3) = "090", _
"090", vbNullString)
' porovnani s ulozenou hodnotou, kdyz je TCll&Tmp090 odlisne, hledat ve zdroji
If TCll.Value & Tmp090 <> Tmp Then
Tmp = TCll.Value & Tmp090 ' ulozit novou hodnotu TCll&Tmp090
' hledat
STmp = vbNullString ' vychozi hodnota vysledku
With SBlk
Set SCll = .Find(TCll.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SCll Is Nothing Then ' nalezeno
FrstAddr = SCll.Address
Do
' porovnani prave strany hodnoty v D:D s Tmp090
If IIf(Len(SCll.Offset(0, 2).Value) = 13 And Right(SCll.Offset(0, 2).Value, 3) = "090", _
"090", vbNullString) = Tmp090 Then
' vysledek ulozit pro pripadne opakovani TCll&Tmp090 v dalsim zaznamu
STmp = SCll.Offset(0, 4).Value
TCll.Offset(0, 4).Value = STmp ' vlozit nalezene do sloupce F:F
Exit Do ' nalezeno, ukoncit hledani
End If
Set SCll = .FindNext(SCll) ' hledat dalsi
Loop While Not SCll Is Nothing And SCll.Address <> FrstAddr
End If
End With
Else ' pro opakujici se TCll&Tmp090 dosadit jiz nalezenou hodnotu
TCll.Offset(0, 4).Value = STmp
End If
Next TCll
Application.ScreenUpdating = True
' odstranit objektove promenne
Set TCll = Nothing
Set SCll = Nothing
Err3:
Set TBlk = Nothing
Set TWsht = Nothing
Err2:
TWbk.Close True ' zavrit zdrojovy soubor
Set TWbk = Nothing
Err1:
Set SBlk = Nothing
Set SWsht = Nothing
End SubPokud dospejes k zaveru, ze prece jenom je potreba nejake zmeny, tak se ozvi.
