Makro og VBA - Hvordan stopper jeg min macro IF ?

Print side | Luk vindue

Hvordan stopper jeg min macro IF ?

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=3713
Udskrevet den: 23.Nov.2024 kl. 08:09

Emne: Hvordan stopper jeg min macro IF ?

Besked fra: Hartig
Emne: Hvordan stopper jeg min macro IF ?
Posteringsdato: 17.Dec.2018 kl. 09:48

Jeg har en en række tjeklister, hvor jeg har indsat en Command Button til automatisk at gemme som PDF-fil på en fast lokation.

Jeg kunne dog godt tænke mig at stoppe macroen med en infobesked, hvis der stadigvæk er røde felter tilbage i arket.

Arket er nemlig opbygget på en sådan måde, at alle felter/rækker der skal udfyldes, men ikke er blevet det endnu, bliver vha Conditional Formatting farvet røde (RGB(248, 203, 173)), hvis de ikke er blevet udfyldt.

Min savemacro ser således ud:

Private Sub GemSomPDF_Click()
If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
MkDir "c:\1_Gemte Tjeklister"
End If

'Set path to Folder
fPath = "c:\1_Gemte Tjeklister\"

'Build File Name from Sheet1 A3, C4 & C2
    fName = Range("A3") & "-" & _
            Range("A4") & "-" & _
            Range("C4")

'Export as PDF to Folder
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
        If Err = 0 Then MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation
End Sub

Svar:

Besked fra: Mads32
Posteringsdato: 17.Dec.2018 kl. 11:32

Du mangler end if, efter din sidste if kommando

Besked fra: maxzpad
Posteringsdato: 17.Dec.2018 kl. 11:40

Man kan godt udelade End If, hvis sætningen skrives på én linje.

Herunder er mit forslag.

Private Sub GemSomPDF_Click()

Dim rngCheck As Range
Dim cllCheck As Range
Dim bRedCell As Boolean

If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
   MkDir "c:\1_Gemte Tjeklister"
End If
'Set path to Folder
    fPath = "c:\1_Gemte Tjeklister\"
'Build File Name from Sheet1 A3, C4 & C2
    fName = Range("A3") & "-" & _
            Range("A4") & "-" & _
            Range("C4")
'Export as PDF to Folder
    Set rngCheck = ActiveSheet.Range("A1:D10") 'Justér til det område dine celler befinder sig i

    For Each cll In rngCheck.Cells

        If cll.DisplayFormat.Interior.Color = RGB(248, 203, 173) Then

            MsgBox "Der er stadig røde felter i arket", vbOKOnly + vbInformation, "Felt-tjek"

            bRedCell = True

            Exit For

        End If

    Next cll

    If Not bRedCell Then

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            If Err = 0 Then MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation

    Else

        MsgBox "PDF-filen blev ikke gemt pga. røde felter", vbOKOnly + vbInformation, "PDF-fil blev ikke gemt"

    End If

End Sub

Besked fra: maxzpad
Posteringsdato: 17.Dec.2018 kl. 11:41

Jeg prøver lige igen (fejl i første paste).

Private Sub GemSomPDF_Click()

Dim rngCheck As Range
Dim cllCheck As Range
Dim bRedCell As Boolean

If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
   MkDir "c:\1_Gemte Tjeklister"
End If
'Set path to Folder
    fPath = "c:\1_Gemte Tjeklister\"
'Build File Name from Sheet1 A3, C4 & C2
    fName = Range("A3") & "-" & _
            Range("A4") & "-" & _
            Range("C4")
'Export as PDF to Folder
    Set rngCheck = ActiveSheet.Range("A1:D10") 'Justér til det område dine celler befinder sig i

    For Each cllCheck In rngCheck.Cells

        If cllCheck.DisplayFormat.Interior.Color = RGB(248, 203, 173) Then

            MsgBox "Der er stadig røde felter i arket", vbOKOnly + vbInformation, "Felt-tjek"

            bRedCell = True

            Exit For

        End If

    Next cll

    If Not bRedCell Then

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            If Err = 0 Then MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation

    Else

        MsgBox "PDF-filen blev ikke gemt pga. røde felter", vbOKOnly + vbInformation, "PDF-fil blev ikke gemt"

    End If

End Sub

Besked fra: Hartig
Posteringsdato: 17.Dec.2018 kl. 12:03

Hej maxzpad

1.000 tak for dit svar.

Jeg har nu prøvet at klippe det ind.

Dog skriver den følgende (billede):

Besked fra: maxzpad
Posteringsdato: 17.Dec.2018 kl. 12:44

Ahr... endnu en fejl/forglemmelse fra min side Cry

Der skal stå cllCheck i stedet for cll.

Besked fra: Hartig
Posteringsdato: 17.Dec.2018 kl. 12:55

Jeg ved simpelthen ikke hvad jeg gør galt.

Nu gemmer den som normalt også selvom der er røde felter i arket.

Farvekoden er jeg ellers 99% sikker på, da jeg har været inde og finde den vha. en macro.

(Jeg er super taknemmeligt for du gider at hjælpe!!)

Private Sub GemSomPDF_Click()

Dim rngCheck As Range
Dim cllCheck As Range
Dim bRedCell As Boolean

If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
   MkDir "c:\1_Gemte Tjeklister"
End If
'Set path to Folder
    fPath = "c:\1_Gemte Tjeklister\"
'Build File Name from Sheet1 A3, C4 & C2
    fName = Range("A3") & "-" & _
            Range("A4") & "-" & _
            Range("C4")
'Export as PDF to Folder
    Set rngCheck = ActiveSheet.Range("A1:E200")

    For Each cllCheck In rngCheck.Cells

        If cllCheck.DisplayFormat.Interior.Color = RGB(248, 203, 173) Then

            MsgBox "Der er stadig røde felter i arket", vbOKOnly + vbInformation, "Felt-tjek"

            bRedCell = True

            Exit For

        End If

    Next cllCheck

    If Not bRedCell Then

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            If Err = 0 Then MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation

    Else

        MsgBox "PDF-filen blev ikke gemt pga. røde felter", vbOKOnly + vbInformation, "PDF-fil blev ikke gemt"

    End If

End Sub

Besked fra: maxzpad
Posteringsdato: 17.Dec.2018 kl. 13:14

Det er klart, at hvis ikke farvekoden rammes spot-on, så vil det ikke fungere.

En måde at finde farvekoden på er, at du stiller dig i en celle, hvor farven er, og herefter skal du over i VBE (Visual Basic Editor) med Alt+F11 og skrive følgende i Immediate-vinduet (Ctrl+G hvis det ikke er vist allerede):

?ActiveCell.DisplayFormat.Interior.Color [tryk Enter]

Dette returnerer farvekoden som en talværdi, som du kan bruge i koden således:

If cllCheck.DisplayFormat.Interior.Color = 11389944 Then

11389944 er den farvekode, jeg får retur, når jeg først har sat farven til RGB(248, 203, 173).

Besked fra: Hartig
Posteringsdato: 17.Dec.2018 kl. 13:29

Fantastisk !!!!

Nu virker det.

Det må være en forkert farvekode!! Jeg fik denne kode retur: 8696052

1.000 mange gange tak for hjælpen.

Besked fra: maxzpad
Posteringsdato: 17.Dec.2018 kl. 13:31

Selv tak. Markér gerne løsningen som "Accepteret løsning".

Besked fra: Hartig
Posteringsdato: 19.Dec.2018 kl. 13:07

Hej igen Max.

Nu har vi kørt med løsningen i et par dage, og det fungerer bare!!

Men så kom jeg til at tænke på i dag, om det egentligt er muligt med mere end 1 IF kommando i samme macro?

Det som jeg nemlig tænker på, det er om det evt. ville være muligt for macroen at gemme som PDF, når der ikke er flere røde felter tilbage (det du hjalp med, som virker perfekt!!), men hvis der så er 1 eller flere "x'er" i kolonne D, som er "Ikke OK" i tjeklisten, så sender den automatisk en mail hvor man bruger informationen fra celle A3 + A4 i emnefeltet.

Fx emne: "Iflg. PM WO "A3", er en eller flere ting hos "A4" Ikke OK."

Jeg ved ikke om det overhovedet kan lade sig gøre?

Mvh Kenneth.

Macroen ser på nuværende tidspunkt således ud:

Private Sub GemSomPDF_Click()

Dim rngCheck As Range
Dim cllCheck As Range
Dim bRedCell As Boolean

If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
   MkDir "c:\1_Gemte Tjeklister"
End If
'Set path to Folder
    fPath = "c:\1_Gemte Tjeklister\"
'Build File Name from Sheet1 A3, A4 & C4
    fName = Range("A3") & "-" & _
            Range("A4") & "-" & _
            Range("C4")
'Export as PDF to Folder
    Set rngCheck = ActiveSheet.Range("A1:E200")

    For Each cllCheck In rngCheck.Cells

        If cllCheck.DisplayFormat.Interior.Color = 8696052 Then

            MsgBox "Der er stadig røde felter i PM tjeklisten", vbOKOnly + vbCritical, "Felt-tjek"

            bRedCell = True

            Exit For

        End If

    Next cllCheck

    If Not bRedCell Then

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            If Err = 0 Then MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation

    Else

        MsgBox "PDF-filen blev ikke gemt pga. røde felter", vbOKOnly + vbCritical, "PDF-fil blev ikke gemt"

    End If

End Sub

Besked fra: maxzpad
Posteringsdato: 19.Dec.2018 kl. 14:41

Hvis der findes x'er i kolonne D, skal PDF'en så stadig genereres? Og hvis ja, ville det så tjene et formål at vedhæfte PDF'en i e-mailen?

Hvem skal i øvrigt være modtager af e-mailen? Og er det Outlook, som er mailprogram?

Det kan sagtens lade sig gøre, men det kræver lidt mere kode (og dermed tid).

Besked fra: Hartig
Posteringsdato: 19.Dec.2018 kl. 14:55

PDF-filen skal stadigvæk genereres, som hidtil.

Hvis der bliver sat kryds i "Ikke OK", så skal vi oprette det der hedder en WO (Work Order) i vores system, så vi kan sikre at det bliver udbedret.

Som det er nu, så ringer vi ind til vores kundeservice og fortæller dem hvad der er "Ikke OK", så de opretter en WO på dette. Men hvis arket kunne sende dem en mail automatisk med de oplysninger de skal bruge, så ville det være super smart både for dem der kører i marken og dem der sidder i kundeservice.

Vi bruger Outlook som mailprogram.

Det ser således ud til dem i marken:

Besked fra: maxzpad
Posteringsdato: 19.Dec.2018 kl. 15:00

Hej Kenneth

I det nedenstående skal du udskifte

.To = "dig@ditdomæne.dk"

med e-mailadressen til jeres kundeservice.

Jeg har ikke mulighed for at teste det, så det må du stå for Smile

--- VBA-kode ----

Private Sub GemSomPDF_Click()

Dim rngCheck As Range
Dim cllCheck As Range
Dim bRedCell As Boolean
Dim bCheckX As Boolean

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Dim sht As Worksheet
Set sht = ActiveSheet

If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
 MkDir "c:\1_Gemte Tjeklister"
End If
'Set path to Folder
 fPath = "c:\1_Gemte Tjeklister\"
'Build File Name from Sheet1 A3, A4 & C4
 With sht

 fName = .Range("A3") & "-" & _
 .Range("A4") & "-" & _
 .Range("C4")

 End With
'Export as PDF to Folder
 Set rngCheck = sht.Range("A1:E200")

 For Each cllCheck In rngCheck.Cells

 If cllCheck.DisplayFormat.Interior.Color = 8696052 Then

 MsgBox "Der er stadig røde felter i PM tjeklisten", vbOKOnly + vbCritical, "Felt-tjek"

 bRedCell = True

 Exit For

 End If

 Next cllCheck

 Set rngCheck = sht.Range("D1:D200")

 For Each cllCheck In rngCheck.Cells

 If UCase(cllCheck) = "X" Then

 bCheckX = True

 Exit For

 End If

 Next cllCheck

 If Not bRedCell Then

 sht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
 Quality:=xlQualityStandard, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=False

 If Err = 0 Then

 MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation

 If bCheckX Then

 With OutMail

 .To = "dig@ditdomæne.dk"

 .Attachments.Add fPath & fName

 .CC = ""
 .BCC = ""

 .Subject = "Iflg. PM WO " & sht.Range("A3") & ", er en eller flere ting hos " & sht.Range("A4") & " Ikke OK."

 .display

 .HTMLbody = "<HTML><BODY>" & _
 "Hej [modtager]" & _
 " " & _
 "Vedhæftet er filen med ..." & _
 " " & _
 "</BODY></HTML>" & _
 " " & _
 OutMail.HTMLbody

 End With

 End If

 End If

 Else

 MsgBox "PDF-filen blev ikke gemt pga. røde felter", vbOKOnly + vbCritical, "PDF-fil blev ikke gemt"

 End If
End Sub

Besked fra: Hartig
Posteringsdato: 19.Dec.2018 kl. 15:18

Det er dybt imponerende hvad du og det kan!!

Dog går den i fejl når jeg kører den.

Besked fra: maxzpad
Posteringsdato: 19.Dec.2018 kl. 15:42

Ok. Det er fordi fName ikke indeholder PDF-filens "efternavn" (extension).

Prøv med dette:

.Attachments.Add fPath & fName & ".pdf"

Besked fra: Hartig
Posteringsdato: 19.Dec.2018 kl. 20:27

Det var derfor.

Nu kører det perfekt!!

Det er simpelthen genialt!!

Ville det egentligt være muligt at komme med en JA/NEJ spørgeboks inden, så man kan vælge hvor vidt man ønsker der skal sendes en mail på oprettelse af ny wo eller ej??

Besked fra: maxzpad
Posteringsdato: 20.Dec.2018 kl. 08:34

Nu med spørgsmål inden e-mail.... Smile

Private Sub GemSomPDF_Click()

 Dim rngCheck As Range
 Dim cllCheck As Range
 Dim bRedCell As Boolean
 Dim bCheckX As Boolean

 Dim OutApp As Object
 Dim OutMail As Object

 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)

 Dim sht As Worksheet
 Set sht = ActiveSheet

 If Len(Dir("c:\1_Gemte Tjeklister", vbDirectory)) = 0 Then
 MkDir "c:\1_Gemte Tjeklister"
 End If

 'Set path to Folder
 fPath = "c:\1_Gemte Tjeklister\"

 'Build File Name from Sheet1 A3, A4 & C4
 With sht

 fName = .Range("A3") & "-" & _
 .Range("A4") & "-" & _
 .Range("C4")

 End With

 'Export as PDF to Folder
 Set rngCheck = sht.Range("A1:E200")

 For Each cllCheck In rngCheck.Cells

 If cllCheck.DisplayFormat.Interior.Color = 8696052 Then

 MsgBox "Der er stadig røde felter i PM tjeklisten", vbOKOnly + vbCritical, "Felt-tjek"

 bRedCell = True

 Exit For

 End If

 Next cllCheck

 If Not bRedCell Then

 sht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
 Quality:=xlQualityStandard, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=False

 If Err = 0 Then

 MsgBox "PM tjekliste er gemt med succes. Den kan findes i C:\Gemte Tjeklister\ når den skal vedhæftes WO i IFS.", vbInformation

 Set rngCheck = sht.Range("D1:D200")

 For Each cllCheck In rngCheck.Cells

 If UCase(cllCheck) = "X" Then

 bCheckX = True

 Exit For

 End If

 Next cllCheck

 If bCheckX Then

 If MsgBox("Iflg. PM WO " & sht.Range("A3") & ", er en eller flere ting hos " & sht.Range("A4") & " Ikke OK." & vbNewLine & vbNewLine & _
 "Vil du sende en e-mail til kundeservice med besked om ny WO?", _
 vbYesNo + vbQuestion, "Send e-mail vedr. ny WO?") = vbYes Then

 With OutMail

 .To = "kenneth.hartig@tomra.com"

 .Attachments.Add fPath & fName & ".pdf"

 .CC = ""
 .BCC = ""

 .Subject = "Iflg. PM WO " & sht.Range("A3") & ", er en eller flere ting hos " & sht.Range("A4") & " Ikke OK."

 .display

 .HTMLbody = "<HTML><BODY>" & _
 "Hej [modtager]" & _
 " " & _
 "Vedhæftet er filen med ..." & _
 " " & _
 "</BODY></HTML>" & _
 " " & _
 OutMail.HTMLbody

 End With

 End If

 End If

 End If

 Else

 MsgBox "PDF-filen blev ikke gemt pga. røde felter", vbOKOnly + vbCritical, "PDF-fil blev ikke gemt"

 End If

End Sub

Besked fra: Hartig
Posteringsdato: 20.Dec.2018 kl. 11:09

Tak Max det er perfekt !!

Rigtig glædelig jul og endnu engang 1.000 tak for hjælpen.

Besked fra: Hartig
Posteringsdato: 08.Mar.2019 kl. 10:43

Hej igen Max

Ved du evt. hvad der går galt her??

Den går i runtime error 1004, men kun ved nogle bestemte kundenumre

Det er ikke kun på min computer den gør dette, men på alles computere.

Det eneste jeg kan se der er af sammenhæng imellem de kundenumre hvor det sker, er at de har A/S efter butiksnavnet.

Kan det være fordi den ikke vil oprette et filnavn hvis der er "/" i det??

(og kan man evt. komme uden om dette??)

Besked fra: maxzpad
Posteringsdato: 08.Mar.2019 kl. 12:39

Hej - ja, jeg mener bestemt, det er skråstregen, som skaber problemet.

Filens navn bliver lagret i variablen fName:

fName = .Range("A3") & "-" & _
.Range("A4") & "-" & _
.Range("C4")

Tilføj dette for at udskifte skråstreger med understreg:

fName = Replace(fName, "/", "_", , , vbTextCompare)

Vælg evt. selv en anden karakter at udskifte med.

Mvh Max

Besked fra: Hartig
Posteringsdato: 08.Mar.2019 kl. 13:47

1.000 tak Max :D

Det virker perfekt.

Print side | Luk vindue