Ga naar inhoud

Rijen tussen cellen met bepaalde kleur(en) verwijderen


lv

Aanbevolen berichten

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.

Link naar reactie
Delen op andere sites

  • Reacties 30
  • Aangemaakt
  • Laatste reactie

Beste reacties in dit topic

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

 

Link naar reactie
Delen op andere sites

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.

Link naar reactie
Delen op andere sites

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? 
 

Link naar reactie
Delen op andere sites

  • 2 weken later...
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? 

Link naar reactie
Delen op andere sites

  • 4 weken later...

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

Link naar reactie
Delen op andere sites


×
×
  • Nieuwe aanmaken...

Belangrijke informatie

We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.