Macro's samenvoegen

[rmk75]

Goedemorgen,

Op ons werk wordt bijgaand bestand via een website gegenereerd (meerdere keren per dag).
Onze afdeling heeft echter maar 13 bepaalde kolommen nodig dus iedereen zit dit bestand, telkens wanneer men deze opnieuw via de site ophaalt, te bewerken totdat ze de benodigde kolommen overhouden.
Nu heb ik dit via 'macro opnemen' redelijk vereenvoudigd maar is het nog niet zoals ik wil.

Graag zou ik het volgende nog aan de macro toegevoegd willen hebben..

Indien in een rij de kolom 'Document Number' blanco is (of een - bevat) dan moet betreffende regel verwijderd worden.
Indien in een rij de kolom 'Document Status' Canceled bevat dan moet betreffende regel verwijderd worden.
Indien in een rij de kolom 'Inspection Blocks' een cijfer 1 t/m 9 bevat (eventueel met letter erachter) dan moet betreffende regel verwijderd worden.

Kort samengevat:
- alleen regels met een document nr. blijven over
- regels waarvan het document is gecanceld worden verwijderd
- regels met een inspection blocks worden verwijderd

Ik heb geprobeerd om dit ook via de 'macro opnemen' functie te doen maar merkte dat er soms regels werden verwijderd terwijl dit niet de bedoeling was..

Wie zou deze 3 voorwaarden in de macro kunnen verwerken?

Alvast bedankt,

Grt rmk

Bekijk bijlage ExportResults_office_MKR001_Tue May 02 02_20_45 CEST 2023.xls

Zo moet het bestand er ongeveer uit gaan zien..

 

[OctaFish]

Heb je wat aan deze macro?

Sub Opschonen()
Dim rng As Range
Dim iC As Integer, i As Integer
Dim arr As Variant

    Set rng = Cells(5, 1).CurrentRegion
    arr = rng
    iC = rng.Rows.Count
    For i = iC To i Step -1
        If (arr(i, 9) = "" Or arr(i, 9) = "-") Or arr(i, 14) = "Canceled" Then
            Rows(i + 4).Delete
        End If
    Next i
    
End Sub

 

[snb]

Welke macro ?

Waarom gebruik je geen autofilter ?
Om welke 13 kolommen gaat het ?

 

[rmk75]

Goedemorgen snb,

Uit de sheet zoals deze uit het systeem komt gebruiken wij de kolommen: A, B, H, I, N, S, U, AQ, AR, AS, AT, AU en AV.
Daarbij voeg ik zelf nog een kolom toe om het verschil aan te geven in referentienummers van kolom AQ en AR.
De lengte van het overzicht varieert van 5 tot soms meer dan 500 regels..

Deze macro heb ik tot dusver:

Sub X_blocks()
'
' X_blocks Macro
'

'
    Rows("1:4").Select
    Selection.Delete Shift:=xlUp
    Columns("C:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("F:I").Select
    Selection.Delete Shift:=xlToLeft
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:AB").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=3
    Columns("N:N").Select
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
    Range("A1:M1").Select
    Range("M1").Activate
    Selection.AutoFilter
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Different reference number"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-2]=RC[-1],RC[-2],""Referentienummer verschilt!!"")"
    Range("J2").Select
    Selection.AutoFill Destination:=Range("J2:J188")
    Range("J2:J188").Select
    Columns("A:N").Select
    Columns("A:N").EntireColumn.AutoFit
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Range("A2").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    Columns("J:J").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:= _
        "Referentienummer verschilt!!", TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("A2").Select
End Sub

Daar zou die van OctaFish het liefst aan toegevoegd moeten worden..


Grt rmk

 

[snb]

Als je dit forum een beetje volgt zou je hebben kunnen weten dat het gebruik van 'Select' en 'Activate' in VBA taboe is.

 

[rmk75]

Goedemorgen snb,

Ik weet niet eens wat dat betekend of doet dus eerlijk heb ik geen idee dat dat taboe is..

 

[AD1957]

Ik ga maar even voorbij aan je laatste antwoord
maar probeer dit eens (ipv. verwijderen kolommen deze verbergen)

Sub Verberg()
Rows("1:4").Delete
ActiveSheet.DrawingObjects.Visible = False      '***of delete
Range("C:G,J:M,O:R,T:AP").EntireColumn.Hidden = True

Dim rng As Range
Dim iC As Integer, i As Integer
Dim arr As Variant

    Set rng = Cells(2, 1).CurrentRegion
    arr = rng
    iC = rng.Rows.Count
    For i = iC To 1 Step -1
        If (arr(i, 9) = "" Or arr(i, 9) = "-") Or arr(i, 14) Like "Cancel*" Or IsNumeric(Left(arr(i, 21), 1)) Then
            Rows(i).EntireRow.Hidden = True '***of delete
        End If
    Next i

    
With Range("AR2:AR" & iC) '**********ipv extra kolom voorwaardelijke opmaak
    .FormatConditions.Add Type:=xlExpression, Formula1:="=$AQ2<>$AR2"
    .FormatConditions(1).Interior.Color = 65535
End With

End Sub

Code aangepast

 

[rmk75]

Als je dit forum een beetje volgt zou je hebben kunnen weten dat het gebruik van 'Select' en 'Activate' in VBA taboe is.

Goedemiddag snb,

Als dit gaat over de 'Select' en 'Activate' in mijn macro.., deze had ik gemaakt met de standaard macro opneemfunctie van Excel.

Mag ik vragen waarom dat taboe is. Mijn kennis van macro's is nihil dus ben eerlijk gezegd wel benieuwd..

Grt rmk

 

[rmk75]

Goedemiddag AD1957,

Bedankt voor jouw oplossing, hier kan ik zeker wat mee..
Ik ga 'm morgen op m'n werk maar eens testen.

Grt rmk

 

[rmk75]

Goedenavond AD1957,

Zou je de macro wellicht nog iets aan willen passen?

Van de zichtbare kolommen automatisch de breedte aanpassen en de eerste regel vastzetten (dit is makkelijker werken indien we heel veel regels hebben).

Bvd

rmk

 

[puppie]

test

 

[rmk75]

Top, kan het topic weer openen!!

Bedankt!

Grt rmk

 

[AD1957]

#10 zo?

Sub Verberg()
Dim i As Integer
Dim arr As Variant

Rows("1:4").Delete
ActiveSheet.DrawingObjects.Visible = False      '***of delete

arr = Cells(1).CurrentRegion
  
For i = UBound(arr) To 1 Step -1
    If (arr(i, 9) = "" Or arr(i, 9) = "-") Or arr(i, 14) Like "Cancel*" Or IsNumeric(Left(arr(i, 21), 1)) Then
        Rows(i).EntireRow.Hidden = True '***of delete
    End If
Next i

    
With Range("AR2:AR" & UBound(arr)) '**********ipv extra kolom voorwaardelijke opmaak
    .FormatConditions.Add Type:=xlExpression, Formula1:="=$AQ2<>$AR2"
    .FormatConditions(1).Interior.Color = 65535
End With

Range("A:AV").Columns.AutoFit
Application.Goto Range("A2")
ActiveWindow.FreezePanes = True
Range("C:G,J:M,O:R,T:AP").EntireColumn.Hidden = True
End Sub

Als je heel veel regels hebt werkt dit traag.

 

[rmk75]

Goedenavond AD1957,

Top, werkt zoals ik 't in gedachten had.
Hartstikke bedankt!

Ik had op verzoek van m'n collega nog een aanpassing gemaakt waarbij ik 2 extra kolommen verberg en nog een filter op de eerste regel zet.
Dat werkt gewoon.

Maar nu is de wens dat containers welke 'Departed' zijn ook verwijderd worden.

Nu had ik gedacht dat mijn aanpassing zou werken maar hierop krijg ik een compileerfout 'Sub of Function is niet gedefinieerd'

Sub Verberg()
Dim i As Integer
Dim arr As Variant

Rows("1:4").Delete
ActiveSheet.DrawingObjects.Visible = False      '***of delete

arr = Cells(1).CurrentRegion
  
For i = UBound(arr) To 1 Step -1
    [COLOR="#FF0000"]If (arr(i, 7) = "Departed")[/COLOR] Or arr(i, 14) Like "Cancel*" Or IsNumeric(Left(arr(i, 21), 1)) Then
        Rows(i).EntireRow.Hidden = True '***of delete
    End If
Next i

    
With Range("AR2:AR" & UBound(arr)) '**********ipv extra kolom voorwaardelijke opmaak
    .FormatConditions.Add Type:=xlExpression, Formula1:="=$AQ2<>$AR2"
    .FormatConditions(1).Interior.Color = 65535
End With

Range("A1:AR1").Select
Selection.AutoFilter
Range("A:AV").Columns.AutoFit
Application.Goto Range("A2")
ActiveWindow.FreezePanes = True
Range("C:G,J:M,O:R,T:AP,AS:AV").EntireColumn.Hidden = True
End Sub

Hoe haal ik alle 'Departed' containers eruit?


Grt rmk

 

[AD1957]

wijzig dit

If (arr(i, 7) = "Departed")

eens in

If arr(i, 7) = "Departed"

p.s. niet getest

 

[cow18]

what is the size of arr, it needs at least 21 columns, with

arr = Cells(1).CurrentRegion.resize(,21)

 

[rmk75]

Werkt op mijn pc helemaal goed, alleen krijgt m'n collega nu een melding over een compileerfout...
Morgen maar even mee verder...

De aflos staat bijna voor de deur dus ik laat het nu even voor wat het is

In ieder geval nogmaals bedankt voor je oplossingen!!

 

[AD1957]

zie post #3
probeer dit eens.

Sub Verberg_1()
 With Sheets(1)
    .Rows("1:4").Delete
    .DrawingObjects.Visible = False
    
    With .Cells(1, 1).CurrentRegion
        .AutoFilter 7, "<>Departed"
        .AutoFilter 14, "<>Cancelled"
        .AutoFilter 21, "="            [COLOR="#008000"]'******in kolom 21 staan alleen 1 cijfer+letter, dus filter op lege cellen[/COLOR]
    End With
 End With

 Range("A:AV").Columns.AutoFit
 Application.Goto Range("A2")
 ActiveWindow.FreezePanes = True
 Range("C:G,J:M,O:R,T:AP,AS:AV").EntireColumn.Hidden = True
 
 With Range("AR2:AR" & Range("AR" & Rows.Count).End(xlUp).Row)   [COLOR="#008000"] '**********ipv extra kolom voorwaardelijke opmaak[/COLOR]
    .FormatConditions.Add Type:=xlExpression, Formula1:="=$AQ2<>$AR2"
    .FormatConditions(1).Interior.Color = 65535
End With

End Sub

 

[rmk75]

Goedenavond AD1957,

Deze lijkt ook prima te werken.
Ik heb de kleur even iets aangepast en een MsgBox toegevoegd en ben er zeer blij mee.
Alleen even stoeien hoe ik het hier bij alle collega's op hun pc ga krijgen.

Bedankt!!!

Grt rmk

 

[AD1957]

Zet de code in de PERSONAL.xlsb koppel deze dan aan een sneltoets.
lees dit eens: https://www.ablebits.com/office-addins-blog/excel-personal-macro-workbook/
Succes.