V souboru newITems_0628.xls je na radku 3572 zaznam s 13-timistnym Lang item nr koncicim "090", v pok_dat.xls neni odpovidajici zaznam IAT.
Kód: Vybrat vše
Option Explicit
Sub FindAndCopy()
' tento soubor
Dim TFWbk As Workbook, TFWsht As Worksheet, TFBlk As Range, TFCll As Range, TFRow As Long
' data
Dim SWbkN As String, SWbk As Workbook, SWsht As Worksheet, SBlk As Range, SCll As Range
Dim STFClmn As String, SRow As Long
' novy soubor
Dim NPathFile As String, NWbk As Workbook, NWshtN As String
Dim NWsht As Worksheet, NBlk As Range
' support
Dim FrstAddr As String, TmpFormula As String, Tmp As String, Tmp090 As String
' nazev souboru s daty
SWbkN = "pok_dat.xls"
'
' tento sesit, blok zaznamu
Set TFWbk = ActiveWorkbook
Set TFWsht = TFWbk.ActiveSheet
With TFWsht
' kdyz jsou zaznamy, definovat blok TFBlk (B5:Bxx) a zaznamy z bloku A5:BVxx odstranit, format sloupcu
If .Range("b5").Value <> vbNullString Then
Set TFBlk = .Range("b5:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
TFBlk.Resize(TFBlk.Rows.Count, 74).Offset(0, -1).ClearContents
.Range("a:e, g:bv").NumberFormat = "@"
.Range("f:f").NumberFormat = "General" ' vlozene vzorce pro funkcnost vyzaduji tento format bunky
End If
End With
' redefinovat blok TFBlk (B5:Bxx->A5)
Set TFBlk = TFWsht.Range("a5")
'
' otevrit datovy soubor, list, blok zaznamu, overit pritomnost dat
Application.ScreenUpdating = False
On Error Resume Next
Set SWbk = Workbooks.Open(Application.ActiveWorkbook.Path & "\" & SWbkN)
If Err.Number <> 0 Then
MsgBox "Datovy soubor: '" & SWbkN & "' nenalezen", vbOKOnly + vbExclamation
GoTo Err1
End If
Set SWsht = SWbk.ActiveSheet
With SWsht
If .Range("b5").Value = vbNullString Then
MsgBox "Na listu: '" & SWsht.Name & "' v souboru: '" & SWbk.Name & "' nejsou zaznamy", vbOKOnly + vbExclamation
GoTo Err2
End If
Set SBlk = .Range("b5:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
End With
' redefinovat blok SBlk (B5:Bxx->B4:Bxx), metoda Find zacina hledat od druhe bunky vlevo nahore v bloku
Set SBlk = SBlk.Resize(SBlk.Rows.Count + 1).Offset(-1, 0)
Application.ScreenUpdating = True
TFWbk.Activate
'
' novy soubor, list, nacist zaznamy
NPathFile = Application.InputBox("Zadej disk, cestu a nazev noveho souboru se zaznamy pok_new..." & vbCr & vbCr _
& "Vzor: Disk:\adresar\nazev.xls", Default:=Application.ActiveWorkbook.Path & "\", Type:=2)
If NPathFile = "False" Then GoTo Err1 ' storno vraci "False"
On Error Resume Next
Set NWbk = Workbooks.Open(NPathFile) ' otevrit
If Err.Number <> 0 Then
MsgBox "Chyba v zadani noveho souboru - disk|cesta|nazev:" & vbCr & vbCr & NPathFile, vbOKOnly + vbExclamation
GoTo Err2
End If
' list v novem souboru:
''*je pouze jeden***********
Set NWsht = NWbk.ActiveSheet
''*nutno vybrat z vice******
' NWshtN = Application.InputBox("Zadej nazev noveho listu", Type:=2)
' If NWshtN = "False" Then GoTo Err2
' Set NWsht = NWbk.Worksheets(NWshtN)
' If Err.Number <> 0 Then
' MsgBox "List: '" & TWshtN & "' nebyl nalezen", vbOKOnly + vbExclamation
' GoTo Err2
' End If
''**************************
On Error GoTo 0
' novy blok, overeni pritomnosti zaznamu
With NWsht
Set NBlk = .Range("b2:b" & .Cells(Rows.Count, 2).End(xlUp).Row) ' blok ve sloupci B:B
End With
If NBlk.Resize(1, 1).Value = vbNullString Then
MsgBox "Na listu: '" & NWsht.Name & "' v souboru: '" & NWbk.Name & "' nejsou zaznamy na druhem radku", _
vbOKOnly + vbExclamation
NWbk.Close False ' zavrit novy soubor
' odstranit objektove promenne
Set NWsht = Nothing
Set NBlk = Nothing
GoTo Err2
End If
' prenest hodnoty z noveho souboru A2:Exx a G2:BVxx do TFWsht A5:Eyy a G5:BVyy
TFBlk.Resize(NBlk.Rows.Count, 5).Value = NBlk.Resize(NBlk.Rows.Count, 5).Offset(0, -1).Value
TFBlk.Resize(NBlk.Rows.Count, 68).Offset(0, 6).Value = NBlk.Resize(NBlk.Rows.Count, 68).Offset(0, 5).Value
' redefinovat blok TFBlk (A5->B5:Bxx)
Set TFBlk = TFBlk.Resize(NBlk.Rows.Count, 1).Offset(0, 1)
NWbk.Close False
' odstranit objektove promenne
Set NBlk = Nothing
Set NWsht = Nothing
Set NWbk = Nothing
'
' prochazet TFBlk a hledat v SBlk shodu ve sloupci B:B a vlozit vzorec z F:F
Application.ScreenUpdating = False
Tmp = vbNullString ' vychozi hodnota shody pri nalezeni pozitivniho vysledku
For Each TFCll In TFBlk.Cells
If TFCll.Offset(0, 2).Value <> vbNullString Then ' sloupec D:D neni prazdny
Tmp090 = IIf(Len(TFCll.Offset(0, 2).Value) = 13 And Right(TFCll.Offset(0, 2).Value, 3) = "090", _
"090", vbNullString) ' stav posl tri znaku pri delce 13 znaku
If TFCll.Value & Tmp090 <> Tmp Then ' rozdil proti predchozimu zaznamu, nalezt novou hodnotu v SBlk
With SBlk
Set SCll = .Find(TFCll.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SCll Is Nothing Then ' nalezena prvni shoda ve sloupci B:B v datovem souboru
FrstAddr = SCll.Address
Do
' shoda ve sloupcich D:D SCll a TFCll s ohledem na delku - 13 znaku a zakonceni - "090"
If IIf(Len(SCll.Offset(0, 2).Value) = 13 And Right(SCll.Offset(0, 2).Value, 3) = "090", _
"090", vbNullString) = Tmp090 Then
' vzorec do F:F TFBlk
TmpFormula = SCll.Offset(0, 4).FormulaLocal ' nacist vzorec z F:F
SRow = SCll.Row ' radek v SBLK, ulozeno pro pripadne se opakujici shodu v dalsim zaznamu
' identifikovat ve vzorci odkaz na bunku Dxx nebo Exx, upravit odkazy pro vlozeni, vlozit
STFClmn = vbNullString
If InStr(TmpFormula, "D" & SRow) > 0 Then
STFClmn = "D" ' sloupec v SBlk, ulozeno pro pripadne se opakujici shodu v dalsim zaznamu
ElseIf InStr(TmpFormula, "E" & SRow) > 0 Then
STFClmn = "E"
End If
If STFClmn <> vbNullString Then ' identifikovan odkaz na bunku Dxx nebo Exx
' vlozit vzorec,zmena odkazu na radek v TFBlk ve vzorci
TFCll.Offset(0, 4).FormulaLocal = Replace(TmpFormula, STFClmn & SRow, STFClmn & TFCll.Row)
Tmp = TFCll.Value & Tmp090 ' vlozit novou hodnotu pro pripadne se opakujici shodu v dalsim zaznamu
Exit Do ' nalezeno, ukoncit prohledavaci smycku Do - Loop
End If
End If
Set SCll = .FindNext(SCll) ' hledat dal, zda bude nalezena hodnota v B:B a bude shoda v D:D (zakonceni)
Loop While Not SCll Is Nothing And SCll.Address <> FrstAddr
End If
End With
Else ' shoda, lze vlozit do cile nalezeny vzorec, zmena odkazu na radek v cili
TFCll.Offset(0, 4).FormulaLocal = Replace(TmpFormula, STFClmn & SRow, STFClmn & TFCll.Row)
End If
End If
Next TFCll ' dalsi zaznam
TFWsht.UsedRange.Columns.AutoFit ' upravit sirku sloupcu
Application.ScreenUpdating = True
TFWbk.Save ' ulozit tento soubor
MsgBox "Doplneni zaznamu uspesne probehlo", vbOKOnly + vbInformation
' odstranit objektove promenne
Set TFCll = Nothing
Set SCll = Nothing
Err2:
Set SBlk = Nothing
Set SWsht = Nothing
SWbk.Close True ' zavrit datovy soubor
Set SWbk = Nothing
Err1:
Set TFBlk = Nothing
Set TFWsht = Nothing
Set TFWbk = Nothing
End Sub
