06. marts 2007 - 13:16Der er
14 kommentarer og 1 løsning
kontrollere to excel-filer for fejl
Jeg har to excel-filer som skulle være ens, men det viser sig at der er nogle fejl i den ene. Derfor kunne jeg godt tænke mig at vha. en formel eller makro går ind og sammenholder de to filer, for at se om de er ens. Det skal være sådan at f.eks. celle C2 i fil 1 skal være identisk med celle C2 i fil 2, og hvis de ikke er ens skal den gerne brokke sig. Jeg ved ikke om de to filer skal slåes sammen til 1 fil for at det kan fungere.
Denne kode indsættes i et neutralt xls-fil (VBA (Alt+F11 / Ark1) I denne fil ark1 dannes en log med navn på de to filer samt evt. uoverensstemmelser. ------------------------------------------------------------------------------------
Dim fNavn1 As String, fNavn2 As String Dim xls1 As Object, xls2 As Object, ræk1, ræk2, kol1, kol2 Public Sub FilKontrol() Rem Slet indhold Cells.Clear
Rem vælg de to filer, der skal sammenlignes fNavn1 = Application.GetOpenFilename fNavn2 = Application.GetOpenFilename
Rem Luk objekter xls1.Quit Set xls1 = Nothing xls2.Quit Set xls2 = Nothing Else MsgBox ("Fil(er) ikke valgt") End If End Sub Private Sub åbnXLSobject(fNavn, xls As Object) Set xls = CreateObject("Excel.application") With xls .Workbooks.Open fNavn End With End Sub Private Sub sammenLigning() Dim logR, maxR, maxK xls1.Sheets(1).Activate ræk1 = xls1.ActiveCell.SpecialCells(xlLastCell).Row kol1 = xls1.ActiveCell.SpecialCells(xlLastCell).Column
Rem Beregn største antal rækker/kolonner If ræk1 > ræk2 Then maxR = ræk1 Else maxR = ræk2 End If
If kol1 > kol2 Then maxK = kol1 Else maxK = kol2 End If
Rem Første fejl-Log-linie logR = 2
Rem De testede filer Cells(1, 1) = fNavn1 Cells(1, 2) = fNavn2
For r = 1 To maxR For k = 1 To maxK If xls1.Cells(r, k) <> xls2.Cells(r, k) Then Cells(logR, 1) = "Ræk: " + CStr(r) + " Kol: " + CStr(k) logR = logR + 1 End If Next k Next r
NB : Opret evt. en knap i den "neutrale fil" med forbindelse til den første SUB i koden: Public Sub FilKontrol() - eller Åbn koden - og start med F5 fra den SUB
Hvis du tager koden fra det link jeg henviste til ovenfor og udskifter T1 og T2 med navnene på dine to filer skulle det meget gerne virke.
Jeg har selv anvendt denne med rigtig gode resultater.
Sub sammenlign() Dim c, x Dim tst As String Dim tst2 As String
For i = 1 To Sheets.Count
For Each c In Workbooks("T1").Sheets(i).Range("A1:R30").Cells If c.Value <> Workbooks("T2").Sheets(i).Range(c.Address) Then Workbooks("T1").Sheets(i).Range(c.Address).Interior.ColorIndex = 3 Workbooks("T2").Sheets(i).Range(c.Address).Interior.ColorIndex = 3 Else Workbooks("T1").Sheets(i).Range(c.Address).Interior.ColorIndex = xlNone Workbooks("T2").Sheets(i).Range(c.Address).Interior.ColorIndex = xlNone End If Next
Den kommer ikke op med en fejlmeddelelse mere, men det eneste der står i det nye ark er de to filnavne, samt Ræk: 1 Kol: 13.
Jeg ved ikke om vi har misforstået hinanden, men i de to filer er der i hver af dem adskillige ark som indeholder store mængder data. Jeg vil gerne have at disse to filer bliver sammenlignet.
Den kode jeg har lagt ind, der er udarbejdet af excelent, sammenligner to Excel projektmapper og alle de i projektmappen værende ark.
Det eneste du skal gøre er, at udskifte T1 med den ene fils navn og T2 med den anven fils navn. Herefter kører du makroen (begge filer skal være åben).
Dim fNavn1 As String, fNavn2 As String Dim xls1 As Object, xls2 As Object, ræk1, ræk2, kol1, kol2, Ark1, Ark2, arkNr Public Sub FilKontrol() Rem Slet indhold Cells.Clear
Rem vælg de to filer, der skal sammenlignes fNavn1 = Application.GetOpenFilename fNavn2 = Application.GetOpenFilename
Rem Luk objekter xls1.Quit Set xls1 = Nothing xls2.Quit Set xls2 = Nothing Exit Sub fejl: MsgBox ("Fil(er) ikke valgt") End Sub Private Sub åbnXLSobject(fNavn, xls As Object) Set xls = CreateObject("Excel.application") With xls .Workbooks.Open fNavn End With End Sub Private Sub sammenLigning() Dim logR, maxR, maxK Ark1 = xls1.Sheets.Count Ark2 = xls2.Sheets.Count
Rem Første fejl-Log-linie logR = 2
Rem De testede filer + antal ark Cells(1, 1) = fNavn1 + "/" + CStr(Ark1) Cells(1, 2) = fNavn2 + "/" + CStr(Ark2)
For arkNr = 1 To xls1.Sheets.Count xls1.Sheets(arkNr).Activate ræk1 = xls1.ActiveCell.SpecialCells(xlLastCell).Row kol1 = xls1.ActiveCell.SpecialCells(xlLastCell).Column
Rem Beregn største antal rækker/kolonner If ræk1 > ræk2 Then maxR = ræk1 Else maxR = ræk2 End If
If kol1 > kol2 Then maxK = kol1 Else maxK = kol2 End If
For r = 1 To maxR For k = 1 To maxK If xls1.Cells(r, k) <> xls2.Cells(r, k) Then Cells(logR, 1) = "Ark: " + CStr(arkNr) + " Ræk: " + CStr(r) + " Kol: " + CStr(k) logR = logR + 1 End If Next k Next r Next End Sub
Koden sættes blot ind i et modul og afvikles som en almindelig makro.
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
Ny bruger
Nybegynder
Opret
Preview
