Sub för att välja en arbetsbok

[TheEcononomist]

Hej!

 

Jag har byggt en sub-rutin "CompareWorksheets" för att jämföra innehållet i två flikar. Den fungerar bra om jag använder två flikar i samma arbetsbok som argument, men nu har jag försökt göra det mer komplicerat genom att låta användaren välja två filer genom dialogrutor.

 

Dialogrutorna för att välja fil fungerar bra, men allt kraschar mot slutet när böckerna ska definieras och skickas till suben. Vad gör jag fel?

Sub VäljBokOchJämför()

Dim Bok1, Bok2 As Excel.Workbook
Dim Str1, Str2 As String


'Hämta sökvägen till arbetsbok 1
Str1 = Application.GetOpenFilename(, , "Välj arbetsbok #1")
If Str1 = "Falskt" Then Exit Sub

'Hämta sökvägen till arbetsbok 2
Str2 = Application.GetOpenFilename(, , "Välj arbetsbok #2")
If Str2 = "Falskt" Then Exit Sub

'Definiera arbetsböckerna
Set Bok1 = Workbooks(Str1)
Set Bok2 = Workbooks(Str2)

'Anropa huvudfunktionen som kräver två argument; ws1 As Worksheet, ws2 As Worksheet)
Call CompareWorksheets(Bok1.Worksheets("Blad1"), Bok2.Worksheets("Blad1"))


End Sub

[Ove Söderlund]

Mitt förslag:

Sub VäljBokOchJämför()

Dim Str1 As String, Str2 As String

'Hämta sökvägen till arbetsbok 1
Str1 = Application.GetOpenFilename(, , "Välj arbetsbok #1")
If Str1 = "Falskt" Then Exit Sub

'Hämta sökvägen till arbetsbok 2
Str2 = Application.GetOpenFilename(, , "Välj arbetsbok #2")
If Str2 = "Falskt" Then Exit Sub

'Anropa huvudfunktionen som kräver två argument; ws1 As Worksheet, ws2 As Worksheet)
Call CompareWorksheets(Str1, Str2)

End Sub

Sub CompareWorksheets(string1 As String, string2 As String)

    Workbooks.Open Filename:=string1
    Workbooks.Open Filename:=string2
    
' Resterade kod här som utför jämförelse mellan arbetsböckerna

End Sub

Skicka bara filnamnen som strängar till Compare-subben och utför den övriga koden där.

 

[TheEcononomist]

Mitt förslag:

Sub VäljBokOchJämför()

Dim Str1 As String, Str2 As String

'Hämta sökvägen till arbetsbok 1
Str1 = Application.GetOpenFilename(, , "Välj arbetsbok #1")
If Str1 = "Falskt" Then Exit Sub

'Hämta sökvägen till arbetsbok 2
Str2 = Application.GetOpenFilename(, , "Välj arbetsbok #2")
If Str2 = "Falskt" Then Exit Sub

'Anropa huvudfunktionen som kräver två argument; ws1 As Worksheet, ws2 As Worksheet)
Call CompareWorksheets(Str1, Str2)

End Sub

Sub CompareWorksheets(string1 As String, string2 As String)

    Workbooks.Open Filename:=string1
    Workbooks.Open Filename:=string2
    
' Resterade kod här som utför jämförelse mellan arbetsböckerna

End Sub

Skicka bara filnamnen som strängar till Compare-subben och utför den övriga koden där.

 

 

Tack! Men går det inte att mata in det som flikar på något sätt? Tror det blir lite jobbigt att ändra i det långa makrot sedan nämligen. Är det nödvändigt att öppna filerna som du föreslår eller kan man ha dem stängda?

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)

'r är radnummer, c är kolumnnummer
Dim r As Long, c As Integer

'lr & lc är det använda området i respektive bok
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer

'Max är det antal rader/kolumner som behövs i målboken. Den får samma värde som det blad som har störst område
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String

'rptWB är målboken
Dim rptWB As Workbook, DiffCount As Long


    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."
    Set rptWB = Workbooks.Add
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC
        Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
        For r = 1 To maxR
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, c).FormulaLocal
            cf2 = ws2.Cells(r, c).FormulaLocal
            On Error GoTo 0
            If cf1 <> cf2 Then
                DiffCount = DiffCount + 1
                Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
            End If
        Next r
    Next c
    
    
    'Formatera rapporten. Hela det använda cellområdet blir gult. Formater blir "värde blad 1"<>"Värde blad 2"
    
    Application.StatusBar = "Formatting the report..."
    With Range(Cells(1, 1), Cells(maxR, maxC))
        .Interior.ColorIndex = 19
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error Resume Next
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error GoTo 0
    End With
    Columns("A:IV").ColumnWidth = 20
    rptWB.Saved = True
    If DiffCount = 0 Then
        rptWB.Close False
    End If
    Set rptWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
'Visa antalet skillnader
    MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
        "Compare " & ws1.Name & " with " & ws2.Name
End Sub

Så ser jämförelsesubben ut.

[Monshi]

För att kunna jämföra, arbeta med en bok/blad måste denna vara öppen, du måste öppna boken.

Enda undantaget är om du använder en bok som databas och hämtar rena data från den.

 

Jag antar att felet ligger i denna rad

Call CompareWorksheets(Bok1.Worksheets("Blad1"), Bok2.Worksheets("Blad1"))

att felet kan vara att Worksheet("Blad1") inte finns i ena boken.

Gör om till

Dim wsSource as Worksheet
Dim wbSource as Workbook
Dim wsTarget as Workseeht
Dim wbTarget as Workbook
set wbSource = Workbooks.Open(Bok1)
Set wsSource = wbSource .Worksheets("Blad1")
set wbTarget = Workbooks.Open(Bok2)
Set wsTarget = wbTarget.Worksheets("Blad1")
CompareWorksheets wsSource, wsTarget
wbSource.Close False
wbTarget.Close False

Typ. Dvs öppna böckerna, hitta  bladen, skicka bladen och stäng böckerna. False-argumentet ger att ändringar inte sparas.

 

reserverar mig för fel ovan, skriver på frihand.