actie meerdere malen laten uitvoeren

[Bjorkie]

hey,
ik heb al volgend script gevonden,
nu voert dit enkel de eerste lijn uit. al de andere lijne doet die niet.
wat mijn oorspronkelijk idee is is het volgende.
indien in cell B tekst staat, dan de range (X:AH) op deze lijn de lege velden weg nemen, en de ingevulde velden naar links plaatsen (beginnen bij Y)
sheet test is oorsprong
sheet Test 2 is het gewenste resultaat.
dit resultaat moet niet op een afzonderlijke sheet.
(ik copieer initieel eerst de data van origineel sheet naar een tijdelijke sheet, om daar deze acties uit te voeren, om vervolgens een pdf te maken)
zie voorbeeldje.

Sub delete_empty_cells_shift_left()
'script to clear empty cells in a range, and move all other to left
    Sheets("test").Range("X1:AQ250").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlToLeft


End Sub

ik heb dus een functie nodig die deze actie herhaald op iedere lijn, indien in cell B een tekst is.
Bekijk bijlage Book1.xlsx

 

[Cobbe]

De code werkt wel maar de lege cellen zijn niet leeg!!!

Sub delete_empty_cells_shift_left()
'script to clear empty cells in a range, and move all other to left
 With Sheets("test")
   .Rows("1:250").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
 End With
End Sub

 

[Bjorkie]

Hey Cobbe,

ok, als de cellen niet leeg zijn, en er is niets te zien, dan staat er dus in feite "" in deze cell. correct?
hoe kan ik dit omzeilen?

 

[Cobbe]

Neen dan staat er niet "" maar " ".
Dat is een fout die zeer vaak voorkomt doordat de cellen leeggemaakt worden via de spatiebalk ipv de deleteknop te gebruiken.
Je kan alle cellen selecteren die schijnbaar leeg zijn en dan echt leegmaken via de deleteknop.

 

[Bjorkie]

ok,
maar de waarde die in deze cellen staat zou volgens mijn formule lleg moeten zijn
=IF(G5="No";"";(VLOOKUP($D5;'Camera types'!$A$1:$U$102;MATCH(G$1;'Camera types'!$A$1:$V$1;0);FALSE)))
indien in andere cell No geselecteerd, moet deze cel leeg blijven.

of, moet ik anders een andere waarde in deze cell plaatsen, om daarna, al de cellen met deze waarde, te wissen.
voorbeeld:
=IF(G5="No";"empty";(VLOOKUP($D5;'Camera types'!$A$1:$U$102;MATCH(G$1;'Camera types'!$A$1:$V$1;0);FALSE)))
om dan nadat ik deze gekopieerd heb naar mijn test sheet, volgende te doen
select all, if value is "empty" then clear
(of zoiets.. weet nog niet hoe ik dat ga doen, maar het idee is er toch al

 

[Cobbe]

Als je de formules aanpast van "" naar empty kan je volgende code draaien om die cellen echt leeg te maken:

Sub delete_empty_cells_shift_left()
    Dim cl As Range
    'script to clear empty cells in a range, and move all other to left
    For Each cl In ActiveSheet.UsedRange
        If UCase(cl) = "EMPTY" Then
            cl = ClearContents
        End If
    Next
    With Sheets("test")
        .Rows("1:250").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
    End With
End Sub

 

[Bjorkie]

Hey Cobbe, thx
heb er volgende van gemaakt.
enkel, het verschruiven naar de linkse lege cellen voert die enkel uit op row1

Sub delete_empty_cells_shift_left()
    Dim cl As Range
    'script to clear empty cells in a range, and move all other to left
    With Sheets("test")
    For Each cl In ActiveSheet.UsedRange
            If UCase(cl) = "EMPTY" Then
            cl = ClearContents
            Else
                If UCase(cl) = "0" Then
            cl = ClearContents
                End If
            End If
        Next
            With Sheets("test")
        .Rows("1:250").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
            End With
    End With
End Sub

 

[Cobbe]

Probeer het zo eens:

Sub delete_empty_cells_shift_left()
    Dim cl As Range
    'script to clear empty cells in a range, and move all other to left
    With Sheets("test")
    For Each cl In ActiveSheet.UsedRange
            If UCase(cl) = "EMPTY" OR cl = 0 OR cl = "0" Then
              cl = ClearContents
              cl.delete
            End If
        Next
            With Sheets("test")
        .Rows("1:250").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
            End With
    End With
End Sub

anders zit er niets anders op dan de schijnbaar lege cellen handmatig te selecteren en te deleten.

 

[Bjorkie]

ok Cobbe,
de cellen worden leeg gemaakt,
heb nog toegevoegd dat de cellen met 'Yes' en 'No' ook mogen gedelete worden.
nu treed volgend issue op:
daar waar de cell links, leeg is, gaat de inhoud van de rechtse cell naar links.
maar niet tot de eerste vrije kolom (X in mijn geval), maar slechts 1 plaats.

Sub delete_empty_cells_shift_left()
    Dim cl As Range
    'script to clear empty cells in a range, and move all other to left
    With Sheets("test")
    For Each cl In ActiveSheet.UsedRange
            If UCase(cl) = "EMPTY" Or cl = 0 Or cl = "Yes" Or cl = "No" Or cl = "0" Then
              cl = ClearContents
              cl.Delete
            End If
        Next
            With Sheets("test")
        .Rows("1:250").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
            End With
    End With
End Sub

dit is wat ik heb.
het 'blank maken' en verschuiven moet ook enkel in bereik X1:AO20 zijn in deze test.
de kolommen vóór X moeten onaangetast blijven.

 

[Bjorkie]

Hey Cobbe,
ik heb iets gevonden dat werkt

Sub delete_empty_cells_shift_left()
    Dim cl As Range
    'script to clear empty cells in a range, and move all other to left
    With Sheets("test")
        For Each cl In ActiveSheet.Range("G2:AO10")
            If UCase(cl) = "EMPTY" Or cl = 0 Or cl = "Yes" Or cl = "No" Or cl = "0" Or cl = Numeric Then
              cl = ClearContents
'              cl.Delete
            End If
        Next
'    End With
'End Sub

'Sub moveToBlankLeft()
'        Next
'        With Sheets("test")
            Application.EnableEvents = False
                With Range("G2:AO10")
                .Value = .Value
                .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
                End With
            Application.EnableEvents = True
'        .Rows("1:250").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
        End With
'    End With
End Sub

nu moet ik nog de kolombreedte automatisch instellen, bereik selecteren en naar PDF sturen.

 

[Cobbe]

Daar kan je dit voor gebruiken

Columns.AutoFit

Plaats dit voor de End Sub

 

[Bjorkie]

Hey Cobbe,
thanks. nu doet hij het prima.
ik begin zo eindelijk enkele zaken te leren. hoera.
bedankt. :thumb: