Hücre doluysa yanındaki hücreye aktar

[SENNE]

Merhaba arkadaşlar
Bir arkadaşın dosyasından yararlanarak ilişik dosya ile ilgili
"A1" hücresindeki firma adına, "b1" hücresinde yazılı yılına "c1" hücresinden c8 hücresine kadar ki yazılı tutarları sayfa 2 deki tabloya düğmeye tek tıkla aktarmak istiyorum. ancak ben bunu tek tıkla başaramadım. yardımcı olacak arkadaşlara teşekkürler.

 

[Necdet]

Merhaba,

Kodları dener misiniz?
Not : Yeni Firmalar da olabileceğini dikkate aldım.

Sub Aktar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim i As Long
Dim Bul As Range
Dim Kol As Integer
s2.Select
Kol = [B4].End(2).Column + 1
If Kol > 16 Then Kol = 4
Application.ScreenUpdating = False
For i = 2 To s1.[A65536].End(3).Row
    With Range("B:B")
        Set Bul = .Find(s1.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
        If Not Bul Is Nothing Then
            Cells(Bul.Row, Kol) = s1.Cells(i, "C")
        Else
            SonSat = [B65536].End(3).Row + 1
            Cells(SonSat, "B") = s1.Cells(i, "A")
            Cells(SonSat, "C") = s1.Cells(i, "B")
            Cells(SonSat, Kol) = s1.Cells(i, "C")
        End If
    End With
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlanmıştır....", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[parametre]

guzel calısma tesekkurler

 

[SENNE]

Merhaba,

Kodları dener misiniz?
Not : Yeni Firmalar da olabileceğini dikkate aldım.

Sub Aktar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim i As Long
Dim Bul As Range
Dim Kol As Integer
s2.Select
Kol = [B4].End(2).Column + 1
If Kol > 16 Then Kol = 4
Application.ScreenUpdating = False
For i = 2 To s1.[A65536].End(3).Row
    With Range("B:B")
        Set Bul = .Find(s1.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
        If Not Bul Is Nothing Then
            Cells(Bul.Row, Kol) = s1.Cells(i, "C")
        Else
            SonSat = [B65536].End(3).Row + 1
            Cells(SonSat, "B") = s1.Cells(i, "A")
            Cells(SonSat, "C") = s1.Cells(i, "B")
            Cells(SonSat, Kol) = s1.Cells(i, "C")
        End If
    End With
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlanmıştır....", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

Çok teşekkür ederin Necdet Kardeş. İyi Çalışmalar Kolay gelsin