kod güncellemesi

[igultekin2000]

iyi günler. Sayfa1' den Sayfa2' ye bazı verileri çekiyorum. Sayfa1' de J hücresi Dolu ise Sayfa1' de D hücresi boş oluyor.

Sub aktar()
Set sl = Sheets("Sayfa2"): Set sk = Sheets("Sayfa1")
Son = sl.Range("A" & Rows.Count).End(3).Row + 1
sat = 3
sl.Range("A3:H" & Son).ClearContents

For i = 3 To sk.Range("B" & Rows.Count).End(3).Row

sl.Cells(sat, "A") = sk.Cells(i, "a")
sl.Cells(sat, "B") = sk.Cells(i, "c")
sl.Cells(sat, "D") = sk.Cells(i, "d") ' banka ismi D hücresine geliyor
sl.Cells(sat, "E") = sk.Cells(i, "I")
sl.Cells(sat, "D") = sk.Cells(i, "J") ' J dolu ise D mutlaka boş oluyor
sl.Cells(sat, "G") = sk.Cells(i, "P")
sl.Cells(sat, "H") = sk.Cells(i, "Q")

sat = sat + 1

Next i
End Sub

aynı hücreye iki farklı sütundan veri getirmeyi ayarlayamadım.

 

[Ziynettin]

Merhaba,

Boş görünen hücreler 3 karakter içeriyor. Sayfa2 K3 arasına listeleyen çalışma.

Sub Aktar_1()
Dim a(), b(), i As Long, Say As Long
Dim S1 As Worksheet, S2 As Worksheet
Set S2 = Sheets("Sayfa2")
Set S1 = Sheets("Sayfa1")
    son = S1.Range("A" & Rows.Count).End(3).Row
    a = S1.Range("A3:Q" & son).Value
    ReDim b(1 To UBound(a), 1 To 6)
        For i = 1 To UBound(a)
            Say = Say + 1
            b(Say, 1) = a(i, 1)
            b(Say, 2) = a(i, 3)
            b(Say, 4) = a(i, 9)
            b(Say, 5) = a(i, 16)
            b(Say, 6) = a(i, 17)
            If Len(a(i, 5)) > 3 Then
                b(Say, 3) = a(i, 4)
            Else
                b(Say, 3) = a(i, 10)
            End If
        Next i
    S2.Range("K3:P" & son).ClearContents
    S2.[K3].Resize(Say, 6) = b
MsgBox "işlem tamam.", vbInformation
End Sub

 

[igultekin2000]

Sorunsuz çalışıyor

Merhaba,

Boş görünen hücreler 3 karakter içeriyor. Sayfa2 K3 arasına listeleyen çalışma.

Sub Aktar_1()
Dim a(), b(), i As Long, Say As Long
Dim S1 As Worksheet, S2 As Worksheet
Set S2 = Sheets("Sayfa2")
Set S1 = Sheets("Sayfa1")
    son = S1.Range("A" & Rows.Count).End(3).Row
    a = S1.Range("A3:Q" & son).Value
    ReDim b(1 To UBound(a), 1 To 6)
        For i = 1 To UBound(a)
            Say = Say + 1
            b(Say, 1) = a(i, 1)
            b(Say, 2) = a(i, 3)
            b(Say, 4) = a(i, 9)
            b(Say, 5) = a(i, 16)
            b(Say, 6) = a(i, 17)
            If Len(a(i, 5)) > 3 Then
                b(Say, 3) = a(i, 4)
            Else
                b(Say, 3) = a(i, 10)
            End If
        Next i
    S2.Range("K3:P" & son).ClearContents
    S2.[K3].Resize(Say, 6) = b
MsgBox "işlem tamam.", vbInformation
End Sub

Elinize sağlık, teşekkürler sorunsuz çalışıyor.