makro ile ver kopyalama

[diablus]

merhabalar aşağıdaki gibi bir makrom var. bu makro çalıştırıldığında A1 ile A10 arasındaki verileri sayfa2 ye kaydediyor. ancak A1 ile A10 arasındaki verileri alırken biçimlendirme formül veya içerisinde ne varsa o şekilde alıyor. ben sadece A1 ile A10 arasındaki hücre değerini kaydetmesini istiyorum. yani hücrede "ahmet" yazıyorsa sayfa 2 ye sadece ahmet olarak kaydetsin

Sub KisiKaydet()
Dim sonSatir As Long
Dim kaynak As Range
Dim hedef As Range

Set kaynak = Worksheets("Sayfa1").Range("A1:A10")
sonSatir = Worksheets("Sayfa2").Cells(Worksheets("Sayfa2").Rows.Count, "A").End(xlUp).Row

If Application.CountA(Worksheets("Sayfa2").Range("A:A")) = 0 Then
sonSatir = 0
End If

Set hedef = Worksheets("Sayfa2").Range("A" & sonSatir + 1)
kaynak.Copy hedef
MsgBox "Kişiler başarıyla kaydedildi!", vbInformation
ThisWorkbook.Save
End Sub

 

[volki_112]

merhabalar aşağıdaki gibi bir makrom var. bu makro çalıştırıldığında A1 ile A10 arasındaki verileri sayfa2 ye kaydediyor. ancak A1 ile A10 arasındaki verileri alırken biçimlendirme formül veya içerisinde ne varsa o şekilde alıyor. ben sadece A1 ile A10 arasındaki hücre değerini kaydetmesini istiyorum. yani hücrede "ahmet" yazıyorsa sayfa 2 ye sadece ahmet olarak kaydetsin

Sub KisiKaydet()
Dim sonSatir As Long
Dim kaynak As Range
Dim hedef As Range

Set kaynak = Worksheets("Sayfa1").Range("A1:A10")
sonSatir = Worksheets("Sayfa2").Cells(Worksheets("Sayfa2").Rows.Count, "A").End(xlUp).Row

If Application.CountA(Worksheets("Sayfa2").Range("A:A")) = 0 Then
sonSatir = 0
End If

Set hedef = Worksheets("Sayfa2").Range("A" & sonSatir + 1)
kaynak.Copy hedef
MsgBox "Kişiler başarıyla kaydedildi!", vbInformation
ThisWorkbook.Save
End Sub

deneyiniz

Sub KisiKaydet()
    Dim kaynak As Range
    Dim hucre As Range
    Dim hedefSatir As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Worksheets("Sayfa1")
    Set ws2 = Worksheets("Sayfa2")
    Set kaynak = ws1.Range("A1:A10")

    ' Sayfa2'deki A sütununda ilk boş satırı bul
    If Application.CountA(ws2.Range("A:A")) = 0 Then
        hedefSatir = 1
    Else
        hedefSatir = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
    End If

    ' Yalnızca dolu hücreleri sırayla kopyala
    For Each hucre In kaynak
        If Trim(hucre.Value) <> "" Then
            ws2.Cells(hedefSatir, "A").Value = hucre.Value
            hedefSatir = hedefSatir + 1
        End If
    Next hucre

    MsgBox "Kişiler başarıyla kaydedildi!", vbInformation
    ThisWorkbook.Save
End Sub

 

[diablus]

deneyiniz

Sub KisiKaydet()
    Dim kaynak As Range
    Dim hucre As Range
    Dim hedefSatir As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Worksheets("Sayfa1")
    Set ws2 = Worksheets("Sayfa2")
    Set kaynak = ws1.Range("A1:A10")

    ' Sayfa2'deki A sütununda ilk boş satırı bul
    If Application.CountA(ws2.Range("A:A")) = 0 Then
        hedefSatir = 1
    Else
        hedefSatir = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
    End If

    ' Yalnızca dolu hücreleri sırayla kopyala
    For Each hucre In kaynak
        If Trim(hucre.Value) <> "" Then
            ws2.Cells(hedefSatir, "A").Value = hucre.Value
            hedefSatir = hedefSatir + 1
        End If
    Next hucre

    MsgBox "Kişiler başarıyla kaydedildi!", vbInformation
    ThisWorkbook.Save
End Sub

çalışıyor çok teşekkürler