Rijen tussen cellen met bepaalde kleur(en) verwijderen

[lv]

6 minuten geleden, emielDS zei:

Waarom is B5 dan rood gekleurd?

Bijgevoegd het bestand waarbij de VO wel juist is. De vorige was een voorbeeld echter was ik niet op de hoogte van het verschil tussen handmatig en VO kleuren.

[emielDS]

bestand vergeten?

[lv]

3 minuten geleden, emielDS zei:

bestand vergeten?

Sorry, beetje dom. Inderdaad vergeten.

vb forumx.xlsx

1 juli 2019 aangepast door lv

[bakerman]

Probeer deze eens.

Sub Rijen_Verwijderen()
    Application.ScreenUpdating = False
    lrow = Range("B" & Rows.Count).End(xlUp).Row
    For Each cl In Range("B2:B" & lrow)
        If Left(cl, 2) = 53 Then
            Do While (Left(cl.Offset(1), 2) <> 51) * (Left(cl.Offset(1), 2) <> 53)
                cl.Offset(1).EntireRow.Delete
            Loop
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[lv]

5 uren geleden, bakerman zei:

Probeer deze eens.

Sub Rijen_Verwijderen()
    Application.ScreenUpdating = False
    lrow = Range("B" & Rows.Count).End(xlUp).Row
    For Each cl In Range("B2:B" & lrow)
        If Left(cl, 2) = 53 Then
            Do While (Left(cl.Offset(1), 2) <> 51) * (Left(cl.Offset(1), 2) <> 53)
                cl.Offset(1).EntireRow.Delete
            Loop
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

Volgens mij werkt die niet. Ik krijg dan Compileerfout: Syntaxisfout.

[lv]

12 minuten geleden, lv zei:

Volgens mij werkt die niet. Ik krijg dan Compileerfout: Syntaxisfout.

Hij werkt wel!! Super bedankt! 

[kweezie wabbit]

Als je verder geen vragen of problemen meer hebt, geef dan een seintje zodat we dit onderwerp kunnen afsluiten.

[lv]

Ik heb nog 2 vragen die ik zelf niet opgelost krijg. De eerste is met mijn eigen macro, die uit een ander bestand gegevens in het bestand plaatst. Onderstaande macro gebruik ik hiervoor, echter importeert die alleen de tekst, maar de afbeeldingen niet. Is hier iets op te bedenken?

 

Sub OpenFile()

Sheets("BOM").AutoFilterMode = False

Dim xFilePath As String
Dim xObjFD As FileDialog
Set xObjFD = Application.FileDialog(msoFileDialogFilePicker)
  With xObjFD
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm; *.xlsb", 1
        .Show
        If .SelectedItems.Count > 0 Then
            xFilePath = .SelectedItems.Item(1)
        Else
        End If
        End With

    Workbooks.Open xFilePath

    Range("A2:G5000").Select
    Selection.Copy
    
    Windows("DUBBELE WAARDES BASIS - KOPIE.xlsm").Activate

    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'checktek

    Dim rRange As Range
    Dim rRange2 As Range
    Dim rCell As Range
    Dim strPath As String
     
    strPath = "U:\"
    Set rRange = Range("E12", Range("E49563").End(xlUp))
    Set rRange2 = Range("L12", Range("L49563").End(xlUp))
   
    For Each rCell In rRange
            If Dir(strPath & rCell) = vbNullString Then
                rCell.Offset(, 7) = "Nee"
            Else
                rCell.Offset(, 7) = "Ja"
            End If
    Next rCell
    ActiveWindow.ScrollRow = 1
    
Sheets("BOM").AutoFilterMode = False

    Rows("11:11").Select
    Selection.EntireRow.Hidden = True
    
   
    ActiveWindow.ScrollRow = 1
    Range("H12").Select

End Sub

 

En dan heb ik nog een probleempje met het samenvoegen van de dubbele waardes, waarmee jullie me eerder geholpen hebben. Het samenvoegen opzich werkt goed, echter lager in de lijst staan verkeerde foto's bij de artikelnummers. Nu heb ik hier al een tijdje mee gestoeit, en blijkt dat de juiste foto zich bevind onder de "oude" foto van het dubbele onderdeel. Dus is er een macro waarmee enkel de bovenste laag foto's (die over de juiste laag zitten) verwijderd worden? 
 

[lv]

Op 9/7/2019 om 07:37, lv zei:

Ik heb nog 2 vragen die ik zelf niet opgelost krijg. De eerste is met mijn eigen macro, die uit een ander bestand gegevens in het bestand plaatst. Onderstaande macro gebruik ik hiervoor, echter importeert die alleen de tekst, maar de afbeeldingen niet. Is hier iets op te bedenken?

 

Sub OpenFile()

Sheets("BOM").AutoFilterMode = False

Dim xFilePath As String
Dim xObjFD As FileDialog
Set xObjFD = Application.FileDialog(msoFileDialogFilePicker)
  With xObjFD
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm; *.xlsb", 1
        .Show
        If .SelectedItems.Count > 0 Then
            xFilePath = .SelectedItems.Item(1)
        Else
        End If
        End With

    Workbooks.Open xFilePath

    Range("A2:G5000").Select
    Selection.Copy
    
    Windows("DUBBELE WAARDES BASIS - KOPIE.xlsm").Activate

    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'checktek

    Dim rRange As Range
    Dim rRange2 As Range
    Dim rCell As Range
    Dim strPath As String
     
    strPath = "U:\"
    Set rRange = Range("E12", Range("E49563").End(xlUp))
    Set rRange2 = Range("L12", Range("L49563").End(xlUp))
   
    For Each rCell In rRange
            If Dir(strPath & rCell) = vbNullString Then
                rCell.Offset(, 7) = "Nee"
            Else
                rCell.Offset(, 7) = "Ja"
            End If
    Next rCell
    ActiveWindow.ScrollRow = 1
    
Sheets("BOM").AutoFilterMode = False

    Rows("11:11").Select
    Selection.EntireRow.Hidden = True
    
   
    ActiveWindow.ScrollRow = 1
    Range("H12").Select

End Sub

 

En dan heb ik nog een probleempje met het samenvoegen van de dubbele waardes, waarmee jullie me eerder geholpen hebben. Het samenvoegen opzich werkt goed, echter lager in de lijst staan verkeerde foto's bij de artikelnummers. Nu heb ik hier al een tijdje mee gestoeit, en blijkt dat de juiste foto zich bevind onder de "oude" foto van het dubbele onderdeel. Dus is er een macro waarmee enkel de bovenste laag foto's (die over de juiste laag zitten) verwijderd worden? 
 

Er is hier niemand die me hiermee verder kan helpen? 

[bakerman]

Aangezien er geen andere kandidaten zijn, deze lost je afbeeldingprobleem op.
 

Sub SamenvoegenVerwijderen()

    Dim sn, myarr, i As Long, j As Long
    
    With Blad1
        sn = .Cells(1).CurrentRegion
    End With
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(sn)
            If IsNumeric(sn(j, 1)) Then
                .Item(sn(j, 2)) = .Item(sn(j, 2)) + sn(j, 1)
            Else
                .Item(sn(j, 2)) = sn(j, 1)
            End If
        Next
        ReDim myarr(1 To .Count, 1 To 6)
        i = 1
        For Each Key In .keys
            myarr(i, 1) = .Item(Key): myarr(i, 2) = Key
            For j = 3 To 6
                myarr(i, j) = Application.Index(Blad1.Cells(1).CurrentRegion, Application.Match(Key, Blad1.Columns(2), 0), j)
            Next
            i = i + 1
        Next
    End With
    Application.ScreenUpdating = False
    With Blad2
        For Each shp In .Shapes
            shp.Delete
        Next
        .Cells(2, 1).Resize(UBound(myarr), 6) = myarr
        
        For i = 1 To UBound(myarr)
            Blad1.Cells(Application.Match(myarr(i, 2), Blad1.Columns(2), 0), 5).Copy .Cells(i + 1, 5)
        Next
        .Range("A:F").EntireColumn.AutoFit
    End With
    Application.Goto Blad2.Cells(1)
    Application.ScreenUpdating = True
End Sub

Voor je andere vraag, plaats een voorbeeldbestand van en naar.

lv.xlsm