Veri Aktar

[vivident]

Merhaba

Ekteki dosyamda ;
Normal aktarma işlemini kodlarım ile yapıyorum

Benim isteğim ;
Eğer syf nosu (A sütununda) tanımlanmış ise fakat GÜN (B sütununda) veri yoksa

Diğer sayfalara aktarma işlemini B Sütunundaki dolu olan hücrenin altına değil (çünkü formül var) B sütundaki 0,9'dan büyük en son değerin altına, sadece D sütunundaki veriyi kopyalasın. Biraz karışık gibi görünse de dosyayı açtığınız daha kolay anlayabileceksiniz

Sub EmreII() 'Modifli aktar
    Dim i%, a%, son%
    With Sayfa6
        For i = 2 To Sheets.Count
            For a = 4 To .Range("A65536").End(3).Row
                If .Cells(a, 1).Value = CStr(Sheets(i).Name) Then
                    son = Sheets(i).Range("B65536").End(3).Row + 1
                    Sheets(i).Cells(son, 4) = .Cells(a, 4).Value
                End If
            Next a
        Next i
    End With
    son = Empty: i = Empty: a = Empty
End Sub

 

[vivident]

konu günceldir

 

[vivident]

son = Sheets(i).Range("B65536").End(3).Row + 1

yukarıda kod sütundaki son dolu hücreyi veriyor yaa, bunu sütundaki sıfırdan büyük son dolu hücre olarak nasıl çevriebiliriz

 

[YUSUF44]

Aşağıdaki gibi bir şey mi istiyorsunuz:

Sub EmreII() 'Modifli aktar
    Dim i%, a%, son%
    With Sayfa6
        For i = 2 To Sheets.Count
            For a = 4 To .Range("A65536").End(3).Row
                If .Cells(a, 1).Value = CStr(Sheets(i).Name) Then
                    son = Sheets(i).Range("B65536").End(3).Row + 1
                    For j = son To 1 Step -1
                    If Sheets(i).Cells(j, "d") > 0 And Sheets(i).Cells(j, "d") <> "" Then
                    
                        Sheets(i).Cells(j + 1, 4) = .Cells(a, 4).Value
                    End If
                    Next
                End If
            Next a
        Next i
    End With
    son = Empty: i = Empty: a = Empty
End Sub

 

[vivident]

Yusuf bey veriyi taşıyacağı yer son dolu hücrenin altı değil, sıfırdan büyük son dolu hücrenin altı.

Örnek üzerinden gidersek

Veri aktar sheetinin = D6 hücresi (R değeri var)
2. nolu sheetin = D20 hücresine taşınacak

Veri aktar sheetinin = D10 hücresi (X değeri var)
4. nolu sheetin = D10 hücresine taşınacak

 

[YUSUF44]

Anlayabildiğim kadarıyla aşağıdaki kodları oluşturdum ama üstüste ikinci kez çalıştırıldığında mantık olarak bir alt hücreye geçmesi gerekirken yine verdiğiniz son örnekte D20'ye yazıyor:

Sub EmreII() 'Modifli aktar
    Dim i%, a%, son%
    With Sayfa6
        For i = 2 To Sheets.Count
            For a = 4 To .Range("A65536").End(3).Row
                If .Cells(a, 1).Value = CStr(Sheets(i).Name) Then
                    If Cells(a, "B") = "" Then
                    For j = Sheets(i).Cells(Rows.Count, "B").End(3).Row To 4 Step -1
                        If Sheets(i).Cells(j, "B") > 0.9 Then
                            Sheets(i).Cells(j + 1, 4) = .Cells(a, 4).Value
                            j = 4
                        End If
                    Next
                    Else
                    son = Sheets(i).Range("B65536").End(3).Row + 1
                    Sheets(i).Cells(son, 4) = .Cells(a, 4).Value
                    End If
                End If
            Next a
        Next i
    End With
    son = Empty: i = Empty: a = Empty
End Sub

 

[vivident]

Yusuf bey teşekkür ederim. İkinci kez üst üste makronun çalışma olayı sorun değil, yardımlarınız için çok teşekkürler

 

[vivident]

Yusuf bey özür dileyerek sizden birşey rica edeceğim. Şu ikinci kez makroyu çalıştırdığımızda bir alt satıra geçmiyordu yaa, önemli değil demiştim lakin önem taşımaya başladı. Bende şöyle birşey düşündüm, verilerin aktarılacağı satır nosu önceden verilirse sanıyorum tüm problemler ortadan kalkar. O yüzde E sütununa aktarılacak olan verilerin hangi satırlara aktarılacağının bilgisini verdim. Acaba koda modif yapabilirmiyiz

A sütununda : aktarılacak sayfa noları
E sütununda : aktarılacak satır noları

İlgili dosyam ektedir

 

[YUSUF44]

O sıra numaralarını kullanmadan aşağıdaki gibi olur sanıyorum:

Sub EmreII() 'Modifli aktar
    Dim i%, a%, son%
    With Sayfa6
        For i = 1 To Sheets.Count
            For a = 4 To .Range("A65536").End(3).Row
                If .Cells(a, 1).Value = CStr(Sheets(i).Name) Then
                    If Cells(a, "B") = "" Then
                    For j = Sheets(i).Cells(Rows.Count, "B").End(3).Row To 4 Step -1
                        If Sheets(i).Cells(j, "B") > 0.9 Then
                            
                            Sheets(i).Cells(WorksheetFunction.Max(Sheets(i).Range("D65536").End(3).Row, _
                            j) + 1, 4) = .Cells(a, 4).Value
                            j = 4
                        End If
                    Next
                    Else
                    son = Sheets(i).Range("B65536").End(3).Row + 1
                    Sheets(i).Cells(son, 4) = .Cells(a, 4).Value
                    End If
                End If
            Next a
        Next i
    End With
    son = Empty: i = Empty: a = Empty
End Sub

 

[vivident]

Yusuf bey çok teşekkür ederim. Örnek süper çalışıyor. Satır numaralı versiyon için rica etsem, çünkü satır numarasını, başka kriterlere göre ben belirlemek istiyorum. (kopyalanan veriler alt altta değil de, kimi zaman kopyalandıkları satır itibari ile aralarında birkaç satır fark olacak) Kod sadece benim belirlediğim satır numarasına aktarma işlemi yapsın

 

[vivident]

Yusuf bey rica etsem satır numaralı bir örnek paylaşmanız mümkünmüdür

 

[vivident]

Yusuf bey yukarıdaki vermiş olduğunuz kodlar ile birlikte, birazda uğraşarak yaptım sanırım, aşağıdaki kod ile istediğim şey oldu. Kırmızı ile belirttiğim kodu ekledim, çalıştı, mantıksal olarak doğru mu sizce de ?

Sheets(i).Cells(Cells(a, "E"), 4)

Sub EmreII() 'Modifli aktar
    Dim i%, a%
    With Sayfa6
        For i = 1 To Sheets.Count
            For a = 4 To .Range("A65536").End(3).Row
                If .Cells(a, 1).Value = CStr(Sheets(i).Name) Then
                    If .Cells(a, 1).Value > 0 And .Cells(a, 2).Value = "" Then
                    Sheets(i).Cells(Cells(a, "E"), 4) = .Cells(a, 4).Value
                    Else
                    Sheets(i).Cells(Cells(a, "E"), 2) = .Cells(a, 2).Value
                    Sheets(i).Cells(Cells(a, "E"), 3) = .Cells(a, 3).Value
                    Sheets(i).Cells(Cells(a, "E"), 4) = .Cells(a, 4).Value
                    End If
                End If
            Next a
        Next i
    End With
    i = Empty: a = Empty
End Sub