Zelfde macro in meerdere kolommen

Status
Niet open voor verdere reacties.
B

BasHD

Gebruiker
Lid geworden
2 dec 2008
Berichten
99
Hallo mensen,

In de volgende macro zou ik graag in willen voeren dat wat er nu gebeurt in kolom D ook in kolom I N O en P zou gebeuren. De waardes 500 en 1 worden weggehaald uit deze kolommen.


Aantal rijen zijn in alle kolommen gelijk.
Ik zal ongetwijfeld ook wel teveel .Select gebruiken en kan deze macro veel eenvoudiger.


Sub HaalWeg500En1()

Dim LastRow, Waarde

Sheets("Lactatie").Select

Range("D2").Select

LastRow = Sheets("Lactatie").Cells(Rows.Count, "D").End(xlUp).Row

For teller = 1 To LastRow

ActiveCell.Offset(1, 0).Select
Waarde = ActiveCell.Value
If Waarde = 500 Then ActiveCell.ClearContents
If Waarde = 1 Then ActiveCell.ClearContents

Next teller

End Sub
 
Code: 
Sub foetsie()
  With Sheets("Lactatie").Range("D:D,I:I,N:P")
    .Replace 500, "", 1
    .Replace 1, "", 1
  End With
End Sub
 
Hallo SNB,

Nou dat werkt een stuk eenvoudiger. Super.

Vervolg vraag :

Is er een mogelijkheid om die range via een InputBox o.i.d te vullen?
InputBox lukt me wel maar hoe zet ik dat in Range?

Groet,

Bas
 
Hoe had je gedacht de verschillende kolommen te kunnen aanduiden ?
 
Hoi snb

Via dit stukje macro kan ik een kolomnummer ingeven.

Sub WelkeKolom()
Dim rngKolomNr As Range
Dim Kolom As String

On Error Resume Next
Do While rngKolomNr Is Nothing
Set rngKolomNr = Application.InputBox("klik een cel in de gewenste kolom aan...", "Kies kolom", , , , , , 8)
Loop
On Error GoTo 0

MsgBox "de gekozen kolom is: " & rngKolomNr.Column

Via dit stukje kun je nummers omzetten in een letter. Probleem is dat ik rngKolomNr niet goed op de plek van die 30 krijg!




Kolom = KolomLetter(30)


With Sheets("Lactatie").Range(" & Kolom & ")
.Replace 500, "", 1
.Replace 1, "", 1
End With

End Sub

Private Function KolomLetter(KolomNummer As Integer) As String
Dim Letter As Integer, Rest As Integer

Letter = KolomNummer \ 27
Rest = KolomNummer - (Letter * 26)

If Letter > 0 Then
KolomLetter = Chr(Letter + 64)
End If

If Rest > 0 Then
KolomLetter = KolomLetter & Chr(Rest + 64)
End If

End Function


Zoiets had ik in gedachten.
 
Suggestie: selcteer een kolom/kolommen, cel/cellen in verschillende kolommen en voer dan de macro uit:

Code: 
Sub foetsie()
  With [COLOR="Red"]Selection.entirecolumn[/COLOR]
    .Replace 500, "", 1
    .Replace 1, "", 1
  End With
End Sub
 
Deze macro zou moeten werken, met dank aan de code van snb ;)

Code: 
Sub Foetsie()
Dim sReeks() As String, sKolom As String, i As Integer
sKolom = InputBox("Typ de kolomletter(s), gescheiden door ';'", "Kolommen aanpassen")

On Error Resume Next
If InStr(1, sKolom, ";") > 0 Then
    sReeks = Split(sKolom, ";")
    For i = 0 To UBound(sReeks)
        sKolom = sReeks(i) & ":" & sReeks(i)
        With Sheets("Lactatie").Range(sKolom)
            .Replace 500, "", 1
            .Replace 1, "", 1
        End With
    Next i
Else
    sKolom = sKolom & ":" & sKolom
    With Sheets("Lactatie").Range(sKolom)
        .Replace 500, "", 1
        .Replace 1, "", 1
    End With
End If

End Sub

Vul een letter in voor één kolom, of meerdere kolomletters.
 
Met dank aan de suggestie van OctaFish:)

Code: 
Sub Foetsie()
  On Error Resume Next
  sq = Split(InputBox("Typ de kolomletter(s), gescheiden door ';'", "Kolommen aanpassen"), ";")
  For j = 0 To UBound(sq)
    With Sheets(1).Range(Replace("x:x", "x", sq(j)))
      .Replace 500, "", 1
      .Replace 1, "", 1
    End With
  Next
End Sub
 
@snb:
Hij is mooi strak en zo, maar hij doet het niet.... hij loopt netjes door z'n routine heen, en leest netjes de variabele in, maar that's it! Enig idee?
 
Nogmaals getest; hij doet exact wat ie moet doen
Zowel met 1 kolom als diverse kolommen: de cellen met 1 of 500 worden verwijderd. Ook als deze als tekst staan gaat het goed.
Plaats anders je bestand eens hier.
 
Dit is 'm. Zoals je ziet, een paar onnozele kolommen, met getallen.
 

Bijlagen

@Octafish

Als Sheets(1) niet Sheets("lactatie") is, werkt de macro wel, maar niet in sheets("lactatie"). Ik zet niet voor niets in mijn ondertekening om niet meer werkbladen te maken dan veelal nodig. Voor jouw bestand:
Code: 
Sub Foetsie()
  On Error Resume Next
  sq = Split(InputBox("Typ de kolomletter(s), gescheiden door ';'", "Kolommen aanpassen"), ";")
  For j = 0 To UBound(sq)
    With Sheets([COLOR="Red"]"Lactatie"[/COLOR]).Range(Replace("x:x", "x", sq(j)))
      .Replace 500, "", 1
      .Replace 1, "", 1
    End With
  Next
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan