Re: [belajar-excel] Placed Result

Khozhot Sun, 21 Feb 2010 17:48:46 -0800

Kalo yang ini q test koq gag bisa jalan yach.

Wassalam.

...zhot thea

Using Opera's revolutionary e-mail client: http://www.opera.com/mail/

On Sun, 21 Feb 2010 12:15:34 +0700, anton suryadi <[email protected]> wrote:

kalo gini gimana,

Sub Updating_Click()
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(4, Columns.Count).End(xlToLeft).Column
For i = 2 To LC
    If Cells(4, i) = Range("B2") Then
        Range(Cells(5, i), Cells(LR, i)).ClearContents
        For n = 5 To LR
            If Cells(n, 1) <> "SUM" Then
                v = "=VLOOKUP(A" & n & ",Source!$A$2:$B$10,2,0)"
                Cells(n, i) = Evaluate(v)
                j = j + Cells(n, i)
            ElseIf Cells(n, i) = "" Then
                Cells(n, i) = j
                j = 0
            End If
        Next n
    End If
Next i
End Sub

selamat belajar.........

>semoga bermanfaat

From: Khozhot <[email protected]>
To: [email protected]
Sent: Sat, February 20, 2010 3:38:51 PM
Subject: Re: [belajar-excel] Placed Result

Alhamdulillah,......
Siii...p dach. Ini yang kumaoooo....

Thanks yach.
q pelajari lagi ach......

--
Wassalam.
...zhot thea
Using Opera's revolutionary e-mail client: http://www.opera.com/mail/

On Sat, 20 Feb 2010 11:12:39 +0700, siti Vi <[email protected]> wrote:

1

MAAF.. ada sedikit salah tulis sedikit dimakronya;  seharusnya seperti ni

Sub Updating4_Click()
   Dim dSourc As Range, dWrite As Range
   Dim Criter As Range, DateBr As Range
   Dim c As Integer, r As Long, i As Long
   Dim Akum As Double

   Set dSourc = Sheets("Source").Range("A2").CurrentRegion.Offset(1, 0)
   Set dSourc = dSourc.Resize(dSourc.Rows.Count - 1, 1)
   Set dWrite = Sheets("Result").Range("A5")
   Set DateBr = Range(dWrite(0, 1), dWrite(0, 1).End(xlToRight))
   Set Criter = Sheets("result").Range("B2")

   r = 1: Akum = 0
   With WorksheetFunction
      c = .Match(Criter, DateBr, 0)
      Application.Calculation = xlCalculationManual
      Do While Not Len(dWrite(r, 1)) = 0
         If .CountIf(dSourc, dWrite(r, 1)) > 0 Then
            i = .Match(dWrite(r, 1), dSourc, 0)
            dWrite(r, c) = dSourc(i, 2)
            Akum = Akum + dSourc(i, 2)
         ElseIf dWrite(r, 1) = "SUM:" Then
            dWrite(r, c) = Akum
            Akum = 0
         End If
         r = r + 1
      Loop
      Application.Calculation = xlCalculationAutomatic
   End With
End Sub

di dalam tabel RESULT kata "SUM" saya bedakan menjadi "SUM:"

agar tidak dianggap data yg ada di tabel SOURCE

(karena di sana ada juga data text "SUM" )

workbook yg siti kirim sebelum ini (ctv_Placed_Result(2).xls)

mohon dideleted saja

2

saran mengenai TOMBOL: saya cabut kembali

(tidak jadi memberi saran)

karena ternyata tombol-tombol itu untuk menjalankan contoh² makro

dari berbagai member..

sorrriii

----- Original Message -----

From: siti Vi

To: [email protected]

Sent: Saturday, February 20, 2010 10:30 AM

Subject: Re: [belajar-excel] Placed Result

prosedur dari siti yg kemarin dikirim dimodifikasi sedikit menjadi seperti ini

Sub Updating4_Click()
   Dim dSourc As Range, dWrite As Range
   Dim Criter As Range, DateBr As Range
   Dim c As Integer, r As Long, i As Long
   Dim Akum As Variant

   Set dSourc = Sheets("Source").Range("A2").CurrentRegion.Offset(1, 0)
   Set dSourc = dSourc.Resize(dSourc.Rows.Count - 1, 1)
   Set dWrite = Sheets("Result").Range("A5")
   Set DateBr = Range(dWrite(0, 1), dWrite(0, 1).End(xlToRight))
   Set Criter = Sheets("result").Range("B2")
   r = 1
   With WorksheetFunction
      c = .Match(Criter, DateBr, 0)
      Application.Calculation = xlCalculationManual
      Do While Not Len(dWrite(r, 1)) = 0
         If .CountIf(dSourc, dWrite(r, 1)) > 0 Then
            i = .Match(dWrite(r, 1), dSourc, 0)
            dWrite(r, c) = dSourc(i, 2)
            Akum = Akum + dWrite(r, c) '<<salah
         ElseIf dWrite(r, 1) = "SUM" Then
            dWrite(r, c) = Akum
            Akum = 0
         End If
         r = r + 1
      Loop
      Application.Calculation = xlCalculationAutomatic
   End With
End Sub

rgds,

siti

Re: [belajar-excel] Placed Result

Kirim email ke