kapalı excel veri aktarma (şartlı)

[netvolxxx]

merhaba forumda daha önce Korhan hocanın yapılmış olan bir uygulamasını kendime uyarladım fakat bi yerde takıldım
kapalı olan dosyaya sorunsuz veri aktarıyor takıldığım yer şurası
taslak isimli sayfamda c14 hücresinde yazan değeri aktarma yapılan ne kadar veri varsa j2den başlatarak aktarmak.
mevcut kod ekranında yaptığımda sadece j2 ye aktarıyor .

Kod olarak bu işlemi nasıl yapabilirim.



Option Explicit

Private Sub CommandButton1_Click()

Dim Zaman As Double, Yol As String, Dosya_Adi As String
Dim Kaynak_Kitap As Workbook, Kaynak_Sayfa As Worksheet
Dim Hedef_Kitap As Workbook, Hedef_Sayfa As Worksheet, Hedef_Son_Satir As Long

Zaman = Timer

Application.ScreenUpdating = False

Set Kaynak_Kitap = ThisWorkbook
Set Kaynak_Sayfa = Kaynak_Kitap.Sheets("Taslak")

Yol = ThisWorkbook.Path & "\"
Dosya_Adi = "Kapalı.xlsm"

Set Hedef_Kitap = Workbooks.Open(Yol & Dosya_Adi, False, False)
Set Hedef_Sayfa = Hedef_Kitap.Sheets("Sayfa1")

If Hedef_Sayfa.Range("A1") = "" Then
With Hedef_Sayfa.Range("A1:J1")
.Value = Array("ÜRÜN ADI", "ÖZELLİK 1", "KUMAŞ ADI", "ÖZELLİK 2", "KUMAŞ ADI 2", "AYAK RENGİ", "AÇIKLAMA", "MİKTAR", "BİRİM FİYATI", "ADI SOYADI")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
End If

Hedef_Son_Satir = Hedef_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 1).End(3).Row + 1


Kaynak_Sayfa.Range("C17:C20").Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("D1720").Copy Hedef_Sayfa.Range("B" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("E17:E20").Copy Hedef_Sayfa.Range("C" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("F17:F20").Copy Hedef_Sayfa.Range("D" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("G17:G20").Copy Hedef_Sayfa.Range("E" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("H17:H20").Copy Hedef_Sayfa.Range("F" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("I17:I20").Copy Hedef_Sayfa.Range("G" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("J17:J20").Copy Hedef_Sayfa.Range("H" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("K17:K20").Copy Hedef_Sayfa.Range("I" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("C14").Copy Hedef_Sayfa.Range("J" & Hedef_Son_Satir)

Hedef_Sayfa.Columns.AutoFit
Hedef_Kitap.Close True

Application.ScreenUpdating = True

MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[veyselemre]

Bu şekilde bir deneyin.

Kaynak_Sayfa.Range("C14").Copy Hedef_Sayfa.Range("J" & Hedef_Son_Satir).Resize(4)

 

[netvolxxx]

Bu şekilde bir deneyin.

Kaynak_Sayfa.Range("C14").Copy Hedef_Sayfa.Range("J" & Hedef_Son_Satir).Resize(4)

üstad
burdaki yazan
Resize(4)

sizde c17 c20 4 tane değer vardır diye yazdınız anladığım kadarıyla ben kod sayfası çalışma yapıyorum diye kısa tutmuştum aralığı
aslında istediğim tam şu

açık olan excel dosyamda
c14 alanı müşteri adı soyadı

c17 ile k17 arası satırda 111 de bitiyor.

şöyle bir örnek vereyim
c17 k17 10 satırlık ta verim var diyelim.

kapalı olan excel dosyasına aktarma yapmak istedimde
c17 k17 10 satır veri gelicek (açık olan excelde c14 de veriyi j2 den başlayıp j11 kadar
c hücresinde veri hangi satırda bitiyorsa o kadar aktarma yapması.

 

[netvolxxx]

örnek excel dosyasıda yükledim daha iyi anlaşılması için dosyanın olduğu yerde kapalı.xlsm olması yeterli

 

[veyselemre]

Private Sub CommandButton1_Click()

    Dim Zaman As Double, Yol As String, Dosya_Adi As String
    Dim Kaynak_Kitap As Workbook, Kaynak_Sayfa As Worksheet
    Dim Hedef_Kitap As Workbook, Hedef_Sayfa As Worksheet, Hedef_Son_Satir As Long, Kaynak_Son_Satir As Long

    Zaman = Timer

    Application.ScreenUpdating = False

    Set Kaynak_Kitap = ThisWorkbook
    Set Kaynak_Sayfa = Kaynak_Kitap.Sheets("Taslak")

    Yol = ThisWorkbook.Path & "\"
    Dosya_Adi = "Kapalı.xlsm"

    Set Hedef_Kitap = Workbooks.Open(Yol & Dosya_Adi, False, False)
    Set Hedef_Sayfa = Hedef_Kitap.Sheets("Sayfa1")

    If Hedef_Sayfa.Range("A1") = "" Then
        With Hedef_Sayfa.Range("A1:J1")
            .Value = Array("ÜRÜN ADI", "ÖZELLİK 1", "KUMAŞ ADI", "ÖZELLİK 2", "KUMAŞ ADI 2", "AYAK RENGİ", "AÇIKLAMA", "MİKTAR", "BİRİM FİYATI", "ADI SOYADI")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
    End If

    Kaynak_Son_Satir = Kaynak_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 3).End(3).Row
    Hedef_Son_Satir = Hedef_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 1).End(3).Row + 1

    Kaynak_Sayfa.Range("C18:K" & Kaynak_Son_Satir).Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)
    Hedef_Sayfa.Range("J" & Hedef_Son_Satir).Resize(Kaynak_Son_Satir - 17).Value = Kaynak_Sayfa.Range("C14").Value

    Hedef_Sayfa.Columns.AutoFit
    Hedef_Kitap.Close True

    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[netvolxxx]

veysel üstad eyvallah sağolasın teşekkürr ederim istediğim gibi oldu kod.....