soldaki sayfadam makro ile veri getirtmek

[necip54]

Merhaba,

Geçmiş senelerde bu siteden aldığımyardımlarla çalışma kibaının içindeki son sayfaya solunda bulunan diğer 12 sayfadan makro ile bilgi taşıyan bir makro geliştirilmişti.

Şimdi ise gene bir çalışma kitabının içinde SEYFİ isimli sayfaya SADECE sol bitişiğinde bulunan Ocak2012 isimli sayfadan veri taşımak istiyorum. Eski makroyu aynen uyguladığımda, solda bulunan bütün sayfalarda aynı hücredeki şartta göre bilgi getirdiğinden karışıklık oluyor. Bu makroyu SADECE Ocak2012 isimli sayfadan veri almak için düzenleme yapamadım. yardımlarınızı bekliyorum.

eski kodlar aşağıdadır.


Sub arabul()
Dim a As String
Dim i As Integer
Dim y As Range
Range("a5:g100").ClearContents
a = ActiveSheet.Range("a1")
For i = 1 To Worksheets.Count
For Each y In Worksheets(i).Range("A2:U5000")
If Trim = Trim(a) Then
q = WorksheetFunction.CountA(ActiveSheet.Range("b4:b100 ")) + 4
ActiveSheet.Cells(q, 2).Value = y.Offset(aa, 6).Value
ActiveSheet.Cells(q, 3).Value = y.Offset(aa, 9).Value
ActiveSheet.Cells(q, 4).Value = y.Offset(aa, 4).Value
ActiveSheet.Cells(q, 5).Value = y.Offset(aa, 2).Value
ActiveSheet.Cells(q, 6).Value = y.Offset(aa, 17).Value
ActiveSheet.Cells(q, 7).Value = y.Offset(aa, 20).Value

End If
Next
If Worksheets(i).Name = ActiveSheet.Name Then Exit Sub
Next
End Sub

Teşekkürler,

 

[Necdet]

Merhaba,

Deneyiniz.

Sub arabul()
    Dim a As String
    Dim i As Integer
    Dim y As Range
    Range("a5:g100").ClearContents
    a = ActiveSheet.Range("a1")
    For Each y In Worksheets("Ocak2012").Range("A2:U5000")
        If Trim(y) = Trim(a) Then
            q = WorksheetFunction.CountA(ActiveSheet.Range("b4:b100 ")) + 4
            ActiveSheet.Cells(q, 2).Value = y.Offset(aa, 6).Value
            ActiveSheet.Cells(q, 3).Value = y.Offset(aa, 9).Value
            ActiveSheet.Cells(q, 4).Value = y.Offset(aa, 4).Value
            ActiveSheet.Cells(q, 5).Value = y.Offset(aa, 2).Value
            ActiveSheet.Cells(q, 6).Value = y.Offset(aa, 17).Value
            ActiveSheet.Cells(q, 7).Value = y.Offset(aa, 20).Value
        End If
    Next
End Sub

 

[necip54]

Merhaba,

Deneyiniz.

Sub arabul()
    Dim a As String
    Dim i As Integer
    Dim y As Range
    Range("a5:g100").ClearContents
    a = ActiveSheet.Range("a1")
    For Each y In Worksheets("Ocak2012").Range("A2:U5000")
        If Trim(y) = Trim(a) Then
            q = WorksheetFunction.CountA(ActiveSheet.Range("b4:b100 ")) + 4
            ActiveSheet.Cells(q, 2).Value = y.Offset(aa, 6).Value
            ActiveSheet.Cells(q, 3).Value = y.Offset(aa, 9).Value
            ActiveSheet.Cells(q, 4).Value = y.Offset(aa, 4).Value
            ActiveSheet.Cells(q, 5).Value = y.Offset(aa, 2).Value
            ActiveSheet.Cells(q, 6).Value = y.Offset(aa, 17).Value
            ActiveSheet.Cells(q, 7).Value = y.Offset(aa, 20).Value
        End If
    Next
End Sub

Sayın Necdet Bey,
Yardımınız için çok teşekkür ederim.İşim görüldü.

Saygılarımla,