Makro ile tablo doldurma

[bmutlu966]

Program dosyasına öyle bir makro yazayım ki, açık olan satış dosyasındaki bilgileri program dosyasındaki tabloya doldursun.

Bunu formül yazarak yapabiliyorum. Ancak makro ile yapmam gerekiyor.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu kullanabilirsiniz. Koddaki kırmızı renkli bölümü kendi sisteminize göre değiştirmeyi unutmayınız.

Option Explicit
 
Sub AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    Dim X As Long, BUL As Range, ADRES As String
    
    Application.ScreenUpdating = False
    
    Set K1 = Workbooks("PROGRAM.xls")
    Workbooks.Open Filename:="[COLOR=red]C:\Documents and Settings\Admin\Desktop\SATIŞ.xls[/COLOR]"
    Set K2 = Workbooks("SATIŞ.xls")
    
    K1.Activate
    
    Range("B3:I65536").ClearContents
    
    For X = 3 To Range("A65536").End(3).Row
        Set BUL = K2.Sheets(1).Range("A:A").Find(Cells(X, 1), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            Select Case K2.Sheets(1).Cells(BUL.Row, "C")
                Case Is = "A"
                Cells(X, 2) = Cells(X, 2) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "B"
                Cells(X, 3) = Cells(X, 3) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "C"
                Cells(X, 4) = Cells(X, 4) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "D"
                Cells(X, 5) = Cells(X, 5) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "E"
                Cells(X, 6) = Cells(X, 6) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "F"
                Cells(X, 7) = Cells(X, 7) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "G"
                Cells(X, 8) = Cells(X, 8) + K2.Sheets(1).Cells(BUL.Row, "F")
                Case Is = "H"
                Cells(X, 9) = Cells(X, 9) + K2.Sheets(1).Cells(BUL.Row, "F")
            End Select
        Set BUL = K2.Sheets(1).Range("A:A").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next
    
    K2.Close
    
    Set K1 = Nothing
    Set K2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[bmutlu966]

Çok teşekkürler

 

[muhendis1755]

Makro ile tablo doldurmak

Merhaba,

Benim bir tablom var ön sayfada ki verileri arkada ki tablo ya makro ile aktarmak istiyorum.Yardımlarınızı bekliyorum.