Avatar billede HHA Professor
17. oktober 2022 - 12:25 Der er 10 kommentarer

VBA, hjælp til flere If'er

Hejsa,

Jeg er kørt fast i hvordan jeg får indsat en ekstra If eller hvad der er jeg skal have indsat 😒

Har nedestående kode, hvor den kigger på om der står JA eller NEJ i det andet ark(fil) som den skal hente fra.
Jeg vil så have den til at springe de linjer over hvor der står Fravælg.
Håber der er en der kan sparke mig i den rigtige retning....

ws1.Cells(iCnt, "B").Value = 1
        ws1.Cells(iCnt, "C").Value = src.Worksheets("Kalk").Cells(iCnt, "D").Value
        ws1.Cells(iCnt, "C").BorderAround xlContinuous
           
            If src.Worksheets("Kalk").Cells(iCnt, "B") = "JA" Then
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 6
                ws1.Cells(iCnt, "B").Value = ""
           
            ElseIf ws1.Cells(iCnt, "C") = "" Then
                ws1.Cells(iCnt, "B") = ""
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
            Else
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
                       
            End If
          ' If src.Worksheets("Kalk").Cells(iCnt, "B") = "NEJ" Then
         
                     
        ws1.Cells(iCnt, "D").Value = src.Worksheets("Kalk").Cells(iCnt, "E").Value
        ws1.Cells(iCnt, "D").BorderAround xlContinuous
        ws1.Cells(iCnt, "E").Value = src.Worksheets("Kalk").Cells(iCnt, "F").Value
        ws1.Cells(iCnt, "E").BorderAround xlContinuous
        ws1.Cells(iCnt, "F").Value = src.Worksheets("Kalk").Cells(iCnt, "I").Value
        ws1.Cells(iCnt, "F").BorderAround xlContinuous
        ws1.Cells(iCnt, "G").Value = src.Worksheets("Kalk").Cells(iCnt, "J").Value
        ws1.Cells(iCnt, "G").BorderAround xlContinuous
        ws1.Cells(iCnt, "H").Value = src.Worksheets("Kalk").Cells(iCnt, "K").Value
        ws1.Cells(iCnt, "H").BorderAround xlContinuous
        ws1.Cells(iCnt, "I").Value = src.Worksheets("Kalk").Cells(iCnt, "L").Value
        ws1.Cells(iCnt, "I").BorderAround xlContinuous
        ws1.Cells(iCnt, "J").Value = src.Worksheets("Kalk").Cells(iCnt, "A").Value
        ws1.Cells(iCnt, "J").BorderAround xlContinuous
        ws1.Cells(iCnt, "K").Value = src.Worksheets("Kalk").Cells(iCnt, "C").Value
        ws1.Cells(iCnt, "K").BorderAround xlContinuous
        ws1.Cells(iCnt, "L").Value = src.Worksheets("Kalk").Cells(iCnt, "M").Value
        ws1.Cells(iCnt, "L").BorderAround xlContinuous
        ws1.Cells(iCnt, "M").Value = src.Worksheets("Kalk").Cells(iCnt, "U").Value
        ws1.Cells(iCnt, "M").BorderAround xlContinuous
        ws1.Cells(iCnt, "A").BorderAround xlContinuous
        ws1.Cells(iCnt, "B").BorderAround xlContinuous
    Next iCnt
   
      src.Close False         
    Set src = Nothing
   
    Application.ScreenUpdating = True
    Worksheets("Standardpriser").Protect
    EnableSelection = xlNoRestrictions
    'MsgBox "Færdig"
Avatar billede claes57 Ekspert
17. oktober 2022 - 14:20 #1
så ret fra
If src.Worksheets("Kalk").Cells(iCnt, "B") = "JA" Then
til
If src.Worksheets("Kalk").Cells(iCnt, "B") = "FRAVÆLG" Then
' spring over kode'
ElseIf src.Worksheets("Kalk").Cells(iCnt, "B") = "JA" Then

det burde være det hele. Det kan være, at den laver noget for meget, men så indsæt
Next iCnt
ved 'spring over kode' (det er en grim løsning ikke at slutte loop samme sted)
Avatar billede HHA Professor
17. oktober 2022 - 14:46 #2
Takker claes57,

Der har jeg været, men kunne ikke rigtigt takle den.
Når jeg bruger ovenstående med Next iCnt oppe ved If koderne, så melder den fejl.
Next whitout For.
Det er lige som om at den så glemmer den For længere oppe i koden.
Tager lige hele koden med ind her.

Application.ScreenUpdating = False
    Worksheets("Standardpriser").Unprotect
    Dim src As Workbook
    Set ws1 = Sheets("Standardpriser")
    ws1.Range("B20:B" & Rows.Count).ClearContents
    ws1.Range("C20:C" & Rows.Count).ClearContents
    ws1.Range("D20:D" & Rows.Count).ClearContents
    ws1.Range("E20:E" & Rows.Count).ClearContents
    ws1.Range("F20:F" & Rows.Count).ClearContents
    ws1.Range("G20:G" & Rows.Count).ClearContents
    ws1.Range("H20:H" & Rows.Count).ClearContents
    ws1.Range("I20:I" & Rows.Count).ClearContents
    ws1.Range("J20:J" & Rows.Count).ClearContents
    ws1.Range("K20:K" & Rows.Count).ClearContents
    ws1.Range("K20:L" & Rows.Count).ClearContents
    ws1.Range("M20:M" & Rows.Count).ClearContents
    ws1.Cells.Borders.LineStyle = xlLineStyleNone
   
    ' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
    Set src = Workbooks.Open("J:\Standardpriser.xlsm", True, True)
   
    ' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
    Dim iTotalRows As Integer
    iTotalRows = src.Sheets("Kalk").Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Rows.Count
 
    ' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
    Dim iCnt As Integer        ' COUNTER.
    For iCnt = 20 To iTotalRows
    ws1.Cells(iCnt, "A").Value = "Nej"
       
       
    With ws1.Cells(iCnt, "A").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$A$17:$A$19"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
   
       
        ws1.Cells(iCnt, "B").Value = 1
        ws1.Cells(iCnt, "C").Value = src.Worksheets("Kalk").Cells(iCnt, "D").Value
        ws1.Cells(iCnt, "C").BorderAround xlContinuous
           
            If src.Worksheets("Kalk").Cells(iCnt, "B") = "JA" Then
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 6
                ws1.Cells(iCnt, "B").Value = ""
            If src.Worksheets("Kalk").Cells(iCnt, "B") = "Fravælg" Then

            Next iCnt  ' HER MELDER DEN SÅ FEJL
           
            Else
                If ws1.Cells(iCnt, "C") = "" Then
                ws1.Cells(iCnt, "B") = ""
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
         
        End If
     
        ws1.Cells(iCnt, "D").Value = src.Worksheets("Kalk").Cells(iCnt, "E").Value
        ws1.Cells(iCnt, "D").BorderAround xlContinuous
        ws1.Cells(iCnt, "E").Value = src.Worksheets("Kalk").Cells(iCnt, "F").Value
        ws1.Cells(iCnt, "E").BorderAround xlContinuous
        ws1.Cells(iCnt, "F").Value = src.Worksheets("Kalk").Cells(iCnt, "I").Value
        ws1.Cells(iCnt, "F").BorderAround xlContinuous
        ws1.Cells(iCnt, "G").Value = src.Worksheets("Kalk").Cells(iCnt, "J").Value
        ws1.Cells(iCnt, "G").BorderAround xlContinuous
        ws1.Cells(iCnt, "H").Value = src.Worksheets("Kalk").Cells(iCnt, "K").Value
        ws1.Cells(iCnt, "H").BorderAround xlContinuous
        ws1.Cells(iCnt, "I").Value = src.Worksheets("Kalk").Cells(iCnt, "L").Value
        ws1.Cells(iCnt, "I").BorderAround xlContinuous
        ws1.Cells(iCnt, "J").Value = src.Worksheets("Kalk").Cells(iCnt, "A").Value
        ws1.Cells(iCnt, "J").BorderAround xlContinuous
        ws1.Cells(iCnt, "K").Value = src.Worksheets("Kalk").Cells(iCnt, "C").Value
        ws1.Cells(iCnt, "K").BorderAround xlContinuous
        ws1.Cells(iCnt, "L").Value = src.Worksheets("Kalk").Cells(iCnt, "M").Value
        ws1.Cells(iCnt, "L").BorderAround xlContinuous
        ws1.Cells(iCnt, "M").Value = src.Worksheets("Kalk").Cells(iCnt, "U").Value
        ws1.Cells(iCnt, "M").BorderAround xlContinuous
        ws1.Cells(iCnt, "A").BorderAround xlContinuous
        ws1.Cells(iCnt, "B").BorderAround xlContinuous
    Next iCnt
   
 
    src.Close False           
    Set src = Nothing
   
    Application.ScreenUpdating = True
    Worksheets("Standardpriser").Protect
    EnableSelection = xlNoRestrictions
    'MsgBox "Færdig"
   
ErrHandler:
   
    'src.Close False     
    Set src = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Worksheets("Standardpriser").Protect
    EnableSelection = xlNoRestrictions
    MsgBox "Færdig"
   
End Sub
Avatar billede claes57 Ekspert
17. oktober 2022 - 17:24 #3
den er også gal - du er i en IF, hvor der skal stå JA, og så tester du, om der står FRAVÆLG - det kan jo ikke ske.
Fravælg skal have et ydre loop (før der testet på JA/NEJ) så du springer alt koden over. Jeg har taget det originale loop med iCnt, og lagt en linje ind i starten og en linje næstsidst
----------------------
    For iCnt = 20 To iTotalRows

    If src.Worksheets("Kalk").Cells(iCnt, "B") <> "Fravælg" Then

    ws1.Cells(iCnt, "A").Value = "Nej"
     
     
    With ws1.Cells(iCnt, "A").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$A$17:$A$19"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
 
     
ws1.Cells(iCnt, "B").Value = 1
        ws1.Cells(iCnt, "C").Value = src.Worksheets("Kalk").Cells(iCnt, "D").Value
        ws1.Cells(iCnt, "C").BorderAround xlContinuous
         
            If src.Worksheets("Kalk").Cells(iCnt, "B") = "JA" Then
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 6
                ws1.Cells(iCnt, "B").Value = ""
         
            ElseIf ws1.Cells(iCnt, "C") = "" Then
                ws1.Cells(iCnt, "B") = ""
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
            Else
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
                     
            End If
          ' If src.Worksheets("Kalk").Cells(iCnt, "B") = "NEJ" Then
       
                   
        ws1.Cells(iCnt, "D").Value = src.Worksheets("Kalk").Cells(iCnt, "E").Value
        ws1.Cells(iCnt, "D").BorderAround xlContinuous
        ws1.Cells(iCnt, "E").Value = src.Worksheets("Kalk").Cells(iCnt, "F").Value
        ws1.Cells(iCnt, "E").BorderAround xlContinuous
        ws1.Cells(iCnt, "F").Value = src.Worksheets("Kalk").Cells(iCnt, "I").Value
        ws1.Cells(iCnt, "F").BorderAround xlContinuous
        ws1.Cells(iCnt, "G").Value = src.Worksheets("Kalk").Cells(iCnt, "J").Value
        ws1.Cells(iCnt, "G").BorderAround xlContinuous
        ws1.Cells(iCnt, "H").Value = src.Worksheets("Kalk").Cells(iCnt, "K").Value
        ws1.Cells(iCnt, "H").BorderAround xlContinuous
        ws1.Cells(iCnt, "I").Value = src.Worksheets("Kalk").Cells(iCnt, "L").Value
        ws1.Cells(iCnt, "I").BorderAround xlContinuous
        ws1.Cells(iCnt, "J").Value = src.Worksheets("Kalk").Cells(iCnt, "A").Value
        ws1.Cells(iCnt, "J").BorderAround xlContinuous
        ws1.Cells(iCnt, "K").Value = src.Worksheets("Kalk").Cells(iCnt, "C").Value
        ws1.Cells(iCnt, "K").BorderAround xlContinuous
        ws1.Cells(iCnt, "L").Value = src.Worksheets("Kalk").Cells(iCnt, "M").Value
        ws1.Cells(iCnt, "L").BorderAround xlContinuous
        ws1.Cells(iCnt, "M").Value = src.Worksheets("Kalk").Cells(iCnt, "U").Value
        ws1.Cells(iCnt, "M").BorderAround xlContinuous
        ws1.Cells(iCnt, "A").BorderAround xlContinuous
        ws1.Cells(iCnt, "B").BorderAround xlContinuous
    End If
    Next iCnt

----------------------
det er reelt en
If src.Worksheets("Kalk").Cells(iCnt, "B") <> "Fravælg" Then
End If
uden om din kode, så Fravælg kun tæller iCnt op, og intet laver der ud over.
Avatar billede HHA Professor
18. oktober 2022 - 07:15 #4
Hej claes57,

Tusind tak for din løsning og ikke mindst forklaringen 👍
Den er lige ved at være der.
Har dog et ønske til den og det er at den sætter tomme rækker ind, der hvor der er Fravælg.
Er der en rimelig løsning på at den ikke sætter tomme rækker ind, men bare springer videre til den næste Ja eller Nej?
Avatar billede claes57 Ekspert
18. oktober 2022 - 09:11 #5
det burde være nede ved de sidste linjer:
        ws1.Cells(iCnt, "B").BorderAround xlContinuous
    End If
    Next iCnt

ret til
        ws1.Cells(iCnt, "B").BorderAround xlContinuous
    Else
      'kode til oprettelse af linje
      ws1.Cells(iCnt, "A").Value = ""
    End If
    Next iCnt
Avatar billede HHA Professor
18. oktober 2022 - 13:48 #6
Hej Claes57,

Det var da noget vrøvl jeg fik skrevet.
Jeg vil selvfølgelig ikke have at den indsætter rækker, når den møder Fravælg.
Kan se at jeg fik skrevet ønsker at den skal indsætte rækker, men det gør den.
Jeg vil meget gerne undgå at den gør det 😒

Beklager forvirringen.
Avatar billede claes57 Ekspert
18. oktober 2022 - 14:21 #7
ok, det er lettest med en makro ved siden af. Se fx https://www.absentdata.com/delete-blank-rows/  metode 1
I. Removing Blank Rows with Find & Select
1. Click Find & Select
2. Click to Go to Special
3. Choose  Blanks
4. Click OK and then all the blank rows/cells  will be highlighted
5. Choose the Delete under Cells section on the Home Tab
6. Click Delete Sheet Rows
det kan du optage som makro, og gemme under eget navn - derefter kopierer du selve den dannede kode (undtagen første og sidste linje med Sub) og lægger den ind lige efter
Next iCnt
så den kører det inden arket låses.
Avatar billede HHA Professor
18. oktober 2022 - 14:33 #8
Hej claes57,

Det kunne helt bestemt være en mulighed.
Men problemet er at den i de "tomme" rækker, sætter et nej i kolonne A, samt at der er tomme (afstands) rækker i det overførte materiale. Så det vil ikke du her.
Desværre.
Det er sgu da også noget besværligt noget jeg kommer frem med....
Avatar billede claes57 Ekspert
18. oktober 2022 - 15:47 #9
ok, så er der kun manuel sletning tilbage.
Du har beskyttet arket med Worksheets("Standardpriser").Protect så den skal lige ophæves, og derefter kan du markere flere rækker ved at holde Ctrl nede, og så klikke på linjenumre der skal slettes, og derefter slette dem fra arket.
Til sidst husk at sætte Worksheets("Standardpriser").Protect til igen.
Avatar billede HHA Professor
18. oktober 2022 - 19:38 #10
Hej claes57,

Takker for din hjælpsomhed 👍
Jeg vil ikke sætte den som løst, da der må findes en automatisk løsning.
Jeg vil prøve og lede videre efter en løsning og dukker den op, så kommer den også her.
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester