Coba begini:
Dim rDates As Range
Dim x As Variant
Dim y As Variant
Dim z As Variant
*Dim o As Integer*
With Sheet3
Set rDates = .Range(.Cells(11, 7), .Cells(.Rows.Count, 7).End(xlUp))
End With
y = "Date Supplier -> No. Document"
ListBox1.AddItem y
ListBox2.AddItem y
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A1").Select
'Dokumen Sudah Expired
For Each cl In rDates
Select Case cl.Value
Case Is = Date
x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
ListBox1.AddItem x
cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 7
End Select
Next cl
'Dokumen Akan Expired +7
*For o = 1 To 6*
For Each cl In rDates
Select Case cl.Value
Case Is = Date + o
x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
ListBox2.AddItem x
cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
End Select
Next cl
*Next o*
End Sub
On Fri, Sep 23, 2016 at 1:49 PM, 'Heri Pamungkas ( Gmail )'
ghery.dha...@gmail.com [belajar-excel] <belajar-excel@yahoogroups.com>
wrote:
>
>
> Assalamualaikum.
>
> Dear Teman-Teman Be-Exceller,
>
> Saya ada kendala di panjangnya script berikut,
> nah rencana saya mau looping untuk bagian berwarna biru.
>
> Mohon bantuan idenya.
>
> Berikut Scriptnya :
>
> 'credit to Slamet <slametha...@gmail.com> <slametha...@gmail.com> @
> belajar-excel@yahoogroups.com
> 'Adjustment Heri Pamungkas
>
> Private Sub UserForm_Initialize()
> Dim rDates As Range
> Dim x As Variant
> Dim y As Variant
> Dim z As Variant
>
> With Sheet3
> Set rDates = .Range(.Cells(11, 7), .Cells(.Rows.Count, 7).End(xlUp))
> End With
> y = "Date Supplier -> No. Document"
> ListBox1.AddItem y
> ListBox2.AddItem y
> Cells.Select
> With Selection.Interior
> .Pattern = xlNone
> .TintAndShade = 0
> .PatternTintAndShade = 0
> End With
> Range("A1").Select
>
> 'Dokumen Sudah Expired
> For Each cl In rDates
> Select Case cl.Value
> Case Is = Date
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox1.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 7
> End Select
> Next cl
>
> 'Dokumen Akan Expired +7
> For Each cl In rDates
> Select Case cl.Value
> *Case Is = Date + 1*
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox2.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
> End Select
> Next cl
> For Each cl In rDates
> Select Case cl.Value
> *Case Is = Date + 2*
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox2.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
> End Select
> Next cl
> For Each cl In rDates
> Select Case cl.Value
> *Case Is = Date + 3*
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox2.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
> End Select
> Next cl
> For Each cl In rDates
> Select Case cl.Value
> *Case Is = Date + 4*
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox2.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
> End Select
> Next cl
> For Each cl In rDates
> Select Case cl.Value
> *Case Is = Date + 5*
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox2.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
> End Select
> Next cl
> For Each cl In rDates
> Select Case cl.Value
> *Case Is = Date + 6*
> x = Format(cl.Offset(0, 0).Value, "dd-mmm-yy") & " " &
> Format(cl.Offset(0, -3).Value, "") & " -> " & cl.Offset(0, -1)
> ListBox2.AddItem x
> cl.Offset(0, -4).Resize(, 5).Interior.ColorIndex = 6
> End Select
> Next cl
> End Sub
>
>
>
> وَالسَّلَامُ عَلَيْكُمْ وَرَحْمَةُ اللهِ وَبَرَكَاتُهُ
>
> Warm Regards,
>
>
>
