< návrat zpět

MS Excel

Téma: Porovnávání tabulek rss

Zaslal/a JAK 7.6.2011 12:08

JAKDobrý den, mám vytvořené makro na porovnávání tabulek od Pokiho 2 (přikládám do přílohy) dále mám tabulku, kde makro po stisku tlačítka odstraní nějaké řádky (po opětovném stisku se řádky opět objeví). Když dám překontrolovat tabulku se zakrytými řádky, makro nahlásí chybu, že neodpovídá počet řádků, což je logické. Šlo by to nějak obejít, aby si zakrytých řádků při kontrole nevšímal? Vůbec nevím, jak bych tento problém řešil. Děkuji za případnou pomoc 2

Příloha: zip5193_prikladtabulky.zip (19kB, staženo 21x)
Zaslat odpověď >
misocko(7.6.2011 19:55)#005197
avatar
dnes sa mi uz nechce premyslat, ale isiel by som na to asi pomocnym listom, do ktoreho by som makrom skopiroval iba viditelne riadky, a tie potom porovnalcitovat
Roman(8.6.2011 14:32)#005201
avatar
Vyber soubor hlavní, ve kterém budou rozdíly vypsány jako komentář, a soubor srovnávací v každém vyber srovnávané oblasti a do nějakého souboru vlož toto makro :
Sub POROVNAT()

Do
FileToOpen = Application _
.GetOpenFilename("Hlavní soubor Excel (*.x*), *.x*")
Loop Until FileToOpen <> False
On Error Resume Next
Workbooks.Open (FileToOpen)
HS = ActiveWorkbook.Name
HL = ActiveSheet.Name
HC = ActiveCell.Address
Set Oblast1 = Application.InputBox("Nastavení oblasti pro srovnání v hlavním souboru", _
"Porovnání dvou oblastí", Selection.Address, , , , , 8)
Oblast1.Parent.Select
HaL = ActiveSheet.Name
HaC = Oblast1.Address
Oblast1.Select
HaA = ActiveCell.Address
Do
FileToOpen = Application _
.GetOpenFilename("Srovnávací soubor Excel (*.x*), *.x*")
Loop Until FileToOpen <> False
On Error Resume Next
Workbooks.Open (FileToOpen)
SS = ActiveWorkbook.Name
SL = ActiveSheet.Name
SC = ActiveCell.Address
Set Oblast2 = Application.InputBox("Nastavení oblasti pro srovnání ve srovnávacím souboru", _
"Porovnání dvou oblastí", Selection.Address, , , , , 8)
Oblast2.Parent.Select
SaL = ActiveSheet.Name
SaC = Oblast2.Address
Oblast2.Select
SaA = ActiveCell.Address

'Kontrola poctu radku a sloupců
If Workbooks(HS).Worksheets(HaL).Range(HaC).Rows.Count > Workbooks(SS).Worksheets(SaL).Range(SaC).Rows.Count Then
pr = Workbooks(HS).Worksheets(HL).Range(HaC).Rows.Count
Else
pr = Workbooks(SS).Worksheets(SL).Range(SaC).Rows.Count
End If
If Workbooks(HS).Worksheets(HL).Range(HaC).Rows.Count > Workbooks(SS).Worksheets(SL).Range(SaC).Rows.Count Then
ps = Workbooks(HS).Worksheets(HL).Range(HaC).Columns.Count
Else
ps = Workbooks(SS).Worksheets(SL).Range(SaC).Columns.Count
End If

For i = 0 To pr - 1
For x = 0 To ps - 1
If Workbooks(HS).Worksheets(HaL).Range(HaA).Offset(i, x) <> Workbooks(SS).Worksheets(SaL).Range(SaA).Offset(i, x) Then
Err = 0
With Workbooks(HS).Worksheets(HaL).Range(HaA).Offset(i, x)
.AddComment
If Not Err = 0 Then
Texty = .Comment.Text
Else
Texty = ""
End If
.Comment.Text Text:=SS & Chr(10) & "List " & SaL & ":" & Chr(10) _
& Workbooks(SS).Worksheets(SaL).Range(SaA).Offset(i, x) & Chr(10) & Texty
.Comment.Visible = False
End With
End If
Next x
Next i
Windows(SS).Activate
Sheets(SL).Select
Range(SC).Select
Workbooks(SS).Close SaveChanges:=False
Windows(HS).Activate
Sheets(HL).Select
Range(HC).Select
Workbooks(HS).Close SaveChanges:=True
End Sub

citovat
JAK(8.6.2011 15:43)#005204
JAK
Ahoj,moc děkuju za makro, ale asi jsem nějakej natvrdlej. Jak mám vypsat rozdíly jako komentář, když rozdíly hledám? Pokusil jsem se makro spustit...proběhne a jednu z kontrolovaný tabulek celou okomentuje, ale rozdíly nevyznačí.30citovat
Roman(8.6.2011 16:27)#005206
avatar
V komentáři je název souboru srovnávané oblasti, název listu a na třetím řádku hodnota ve srovnávané oblasti, která není shodná.
Pokud je komentář všude asi jsi nezadal oblasti, které se shodují. Mrkni na komentář a poznáš, co a odkud tam je. Pokud je komentář úzký tak ho musíš rozšířit.citovat
JAK(8.6.2011 17:15)#005211
JAK
Tak jsem to otestoval a makro stále kontroluje i zakryté řádky. Přikládám soubory na otestování. Asi jsem opravdu natvrdelej 2 Každopádně...děkuju moc.
Příloha: zip5211_porovnani.zip (24kB, staženo 15x)
citovat
misocko(8.6.2011 20:09)#005215
avatar
toto Ti skopiruje oznacenu oblast so skrytimi riadkami do pomocneho listu , ten potom mozes porovnat


Sub kopiruj_viditelne()
meno_listu = ActiveSheet.Name
prvy_riadok = Selection.Row
posledny_riadok = Selection.Row + Range(Selection.Address).Rows.Count - 1

Sheets(1).Select
Sheets.Add
Sheets(meno_listu).Select

For riadok = prvy_riadok To posledny_riadok
Rows(riadok).Select
If Selection.EntireRow.Hidden = False Then
Application.CutCopyMode = False
Selection.Copy
Sheets(1).Select
Rows(Range("c36556").End(xlUp).Row + 1).Select
ActiveSheet.Paste
Sheets(meno_listu).Select
End If
Next riadok
Sheets(1).Select
Rows(1).Delete

End Subcitovat
icon Poki(9.6.2011 10:58)#005222
Poki
upravil jsem puvodni kod _ je dost prepracovany, tak si to vyzkousej...
Příloha: zip5222_prikladtabulky.zip (25kB, staženo 20x)
citovat
Roman(9.6.2011 13:18)#005226
avatar
Nyní se budou přeskakovat skryté řádky i sloupce v obou souborech, pro velikost výběru je rozhodující výběr v souboru hlavní. Já jsem původně myslel, že skryté jsou součástí kontroly jen pro test velikosti se nepočítají, vzorový soubor byl jasný skryjí se řádky sloupce,které nemají eqivalent
Sub POROVNAT()

Do
FileToOpen = Application _
.GetOpenFilename("Hlavní soubor Excel (*.x*), *.x*")
Loop Until FileToOpen <> False
On Error Resume Next
Workbooks.Open (FileToOpen)
HS = ActiveWorkbook.Name
HL = ActiveSheet.Name
HC = ActiveCell.Address
Set Oblast1 = Application.InputBox("Nastavení oblasti pro srovnání v hlavním souboru", _
"Porovnání dvou oblastí", Selection.Address, , , , , 8)
Oblast1.Parent.Select
HaL = ActiveSheet.Name
HaC = Oblast1.Address
Oblast1.Select
HaA = ActiveCell.Address
Do
FileToOpen = Application _
.GetOpenFilename("Srovnávací soubor Excel (*.x*), *.x*")
Loop Until FileToOpen <> False
On Error Resume Next
Workbooks.Open (FileToOpen)
SS = ActiveWorkbook.Name
SL = ActiveSheet.Name
SC = ActiveCell.Address
Set Oblast2 = Application.InputBox("Nastavení oblasti pro srovnání ve srovnávacím souboru", _
"Porovnání dvou oblastí", Selection.Address, , , , , 8)
Oblast2.Parent.Select
SaL = ActiveSheet.Name
SaC = Oblast2.Address
Oblast2.Select
SaA = ActiveCell.Address

j = 0
For i = 0 To Workbooks(HS).Worksheets(HL).Range(HaC).Rows.Count - 1
Do While Workbooks(SS).Worksheets(SaL).Range(SaA).Rows(j + 1).Hidden
j = j + 1
Loop
Do While Workbooks(HS).Worksheets(HaL).Range(HaA).Rows(i + 1).Hidden
i = i + 1
Loop
y = 0
For x = 0 To Workbooks(HS).Worksheets(HL).Range(HaC).Columns.Count - 1
Do While Workbooks(SS).Worksheets(SaL).Range(SaA).Columns(y + 1).Hidden
y = y + 1
Loop
Do While Workbooks(HS).Worksheets(HaL).Range(HaA).Columns(x + 1).Hidden
x = x + 1
Loop

If Workbooks(HS).Worksheets(HaL).Range(HaA).Offset(i, x) <> Workbooks(SS).Worksheets(SaL).Range(SaA).Offset(j, y) Then
Err = 0
With Workbooks(HS).Worksheets(HaL).Range(HaA).Offset(i, x)
.AddComment
If Not Err = 0 Then
Texty = .Comment.Text
Else
Texty = ""
End If
.Comment.Text Text:=SS & Chr(10) & "List " & SaL & ":" & Chr(10) _
& Workbooks(SS).Worksheets(SaL).Range(SaA).Offset(j, y) & Chr(10) & Texty
.Comment.Visible = False
End With
End If
y = y + 1
Next x
j = j + 1
Next i
Windows(SS).Activate
Sheets(SL).Select
Range(SC).Select
Workbooks(SS).Close SaveChanges:=False
Windows(HS).Activate
Sheets(HL).Select
Range(HC).Select
Workbooks(HS).Close SaveChanges:=True
End Sub
citovat
JAK(9.6.2011 15:23)#005229
JAK
Děkuju za rady a Makra.Funguje to perfektně 2citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

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.

On-line nástroje