Satır arasına veri yazmak

[igultekin2000]

iyi günler; Veri girilmiş iki sütunlu tablom var. zaman zaman yeni oluşan verileri eski tabloya girmek gerekiyor. Veri girilmiş tabloya veri girme makrosu bulamadım. örnek üzerinde detaylandırdım. Teşekkürler

 

[Ziynettin]

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[igultekin2000]

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

Doğru anlamışsınız, çok teşekkür ederim. bir kaç gündür çözmeye çalışıp örnek aramıştım. iyi çalışmalar. Kusura bakmayın başka bir çalışmama uygulamaya çalıştım kodları aktarıyor ama D:I sütunlarındaki bilgileri siliyor. Bakmanız mümkünse memnun olurum.

 

[igultekin2000]

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Ziynettin]

[D2].Resize(UBound(a),6) = b

Satırında 6 (sutun boyutunu) silin.

[D2].Resize(UBound(a)) = b

olarak kullanın.

 

[igultekin2000]

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

Yanlış anlamadım ise,

Sub test()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("B3:E" & son).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If a(i, 3) = "" Then
        b(i, 1) = a(i, 1)
    Else
        b(i, 1) = a(i, 3)
    End If
    If a(i, 4) = "" Then
        b(i, 2) = a(i, 2)
    Else
        b(i, 2) = a(i, 4)
    End If
Next i
[B3].Resize(UBound(a), 2) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

çok teşekkür edirm , sorunsuz çalışıyor. Sayenizden bir müşkilden daha kurtulduk