• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Shorter code?

Belleke

Active Member
I have a sheet called weekplanning and 5 sheets with the (working) days.
In weekplanning
Data for MO is in column b
TU in column c
We in column D
TH in column E
Fr in column F
These data has to go the daysheets, all starting in B4
I think that this code could be shorter, but I don't see it.
Code:
Sub Weekplanning()
For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Weekplanning" Then
        ws.Range("B4:B28").ClearContents
        End If
    Next ws
sRij1 = 4
sRij2 = 4
sRij3 = 4
sRij4 = 4
sRij5 = 4
For Each c In Range("B4:B28").SpecialCells(xlCellTypeVisible)
    If Len(c) <> 0 And c <> "Pauze" Then
        Sheets("Maandag").Cells(sRij1, "B").Value = c.Value
        sRij1 = sRij1 + 1
    End If
Next
For Each c In Range("C4:C28").SpecialCells(xlCellTypeVisible)
    If Len(c) <> 0 And c <> "Pauze" Then
        Sheets("Dinsdag").Cells(sRij2, "B").Value = c.Value
        sRij2 = sRij2 + 1
    End If
Next
For Each c In Range("D4:D28").SpecialCells(xlCellTypeVisible)
    If Len(c) <> 0 And c <> "Pauze" Then
        Sheets("Woensdag").Cells(sRij3, "B").Value = c.Value
        sRij3 = sRij3 + 1
    End If
Next
For Each c In Range("E4:E28").SpecialCells(xlCellTypeVisible)
    If Len(c) <> 0 And c <> "Pauze" Then
        Sheets("Donderdag").Cells(sRij4, "B").Value = c.Value
        sRij4 = sRij4 + 1
    End If
Next
For Each c In Range("F4:F28").SpecialCells(xlCellTypeVisible)
    If Len(c) <> 0 And c <> "Pauze" Then
        Sheets("Vrijdag").Cells(sRij5, "B").Value = c.Value
        sRij5 = sRij5 + 1
    End If
Next
End Sub
any idee?
 

Fluff13

Active Member
You can do it like
Code:
Sub Weekplanning()
For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "Weekplanning" Then
        Ws.Range("B4:B28").ClearContents
        End If
    Next Ws
sRij1 = 4
sRij2 = 4
sRij3 = 4
sRij4 = 4
sRij5 = 4
For Each c In Range("B4:B28").SpecialCells(xlCellTypeVisible)
    If Len(c) <> 0 And c <> "Pauze" Then
        Sheets("Maandag").Cells(sRij1, "B").Value = c.Value
        sRij1 = sRij1 + 1
    End If
    If Len(c.Offset(, 1)) <> 0 And c.Offset(, 1) <> "Pauze" Then
        Sheets("Dinsdag").Cells(sRij2, "B").Value = c.Offset(, 1).Value
        sRij2 = sRij2 + 1
    End If
    If Len(c.Offset(, 2)) <> 0 And c.Offset(, 2) <> "Pauze" Then
        Sheets("Woensdag").Cells(sRij3, "B").Value = c.Offset(, 2).Value
        sRij3 = sRij3 + 1
    End If
Next
End Sub
So you only have to loop through once
 

p45cal

Well-Known Member
You could also try:
Code:
Sub Weekplanning2()
sRij = [{"Maandag",4;"Dinsdag",4;"Woensdag",4;"Donderdag",4;"Vrijdag",4}]
For i = 1 To UBound(sRij)
  Sheets(sRij(i, 1)).Range("B4:B28").ClearContents
Next i
For Each c In Sheets("Weekplanning").Range("B4:F28").SpecialCells(xlCellTypeVisible)    'I've made assumption that you're copying from the Weekplanning sheet here.
  colm = c.Column - 1
  If Len(c) <> 0 And c <> "Pauze" Then
    Sheets(sRij(colm, 1)).Cells(sRij(colm, 2), "B").Value = c.Value
    sRij(colm, 2) = sRij(colm, 2) + 1
  End If
Next
End Sub
Should you want to add any more sheets to your workbook, the likes of:
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Weekplanning" Then

would clear cells B4:B28 on those too.
With the above code only the 5 sheets named Maandag, Dinsdag, Woensdag, Donderdag & Vrijdag will have those cells cleared.
 
Last edited:
Top