Soru Şartlı Veri Aktar

[Hsn55]

İyi akşamlar;
Ölçü Tespit Tutanağı Sayfasında H3 , J213:J222,M213.M222 ve N213:N222 sayfa aralığındaki verileri makro ile Nakliyat sayfasında ki D,E,F;G sütunlara 10 satırdan başlama kaydı ile aktarabilir miyiz. Şart şöyle olacak eğer veri aktarıldıktan sonra tekrar 2. kez veri aktarmak istediğimizde Ölçü Tespit Tutanağı Sayfasında M223,N223 hücrelerinde m³ ve ster toplamı aynı ise bir önceki aktarılan verinin üzerine yazacak. Toplam farklı ise bir sonraki satıra veriyi aktaracak. Örnekte ki gibi

Ekli dosyalar:

İndir Aktar xlsm

Dosyayı indir Aktar xlsm

dosya.co

 

[muhasebeciyiz]

Sub VeriAktar_Nakliyat()

    Dim wsKaynak As Worksheet
    Dim wsHedef As Worksheet
    Dim m3ToplamYeni As Double, sterToplamYeni As Double
    Dim m3ToplamOnceki As Double, sterToplamOnceki As Double
    Dim baslangicSatiri As Long
    Dim hedefSatir As Long
    Dim sonToplamSatiri As Long
    Dim veriSatirlari As Collection
    Dim i As Variant

    On Error GoTo Hata

    Set wsKaynak = ThisWorkbook.Sheets("ÖLÇÜ TESPİT TUTANAĞI")
    Set wsHedef = ThisWorkbook.Sheets("NAKLİYAT")
    Set veriSatirlari = New Collection
    
    If Not IsNumeric(wsKaynak.Range("M223").Value) Or Not IsNumeric(wsKaynak.Range("N223").Value) Then
        MsgBox "M223 veya N223 hücreleri geçerli sayı içermiyor!", vbCritical
        Exit Sub
    End If

    m3ToplamYeni = wsKaynak.Range("M223").Value
    sterToplamYeni = wsKaynak.Range("N223").Value

    sonToplamSatiri = wsHedef.Cells(wsHedef.Rows.Count, "J").End(xlUp).Row
    
    If sonToplamSatiri < 10 Then
        baslangicSatiri = 10
    Else
        If IsNumeric(wsHedef.Cells(sonToplamSatiri, "J").Value) And IsNumeric(wsHedef.Cells(sonToplamSatiri, "K").Value) Then
            m3ToplamOnceki = wsHedef.Cells(sonToplamSatiri, "J").Value
            sterToplamOnceki = wsHedef.Cells(sonToplamSatiri, "K").Value

            If m3ToplamYeni = m3ToplamOnceki And sterToplamYeni = sterToplamOnceki Then
                baslangicSatiri = sonToplamSatiri - 10
                If baslangicSatiri < 10 Then baslangicSatiri = 10
            Else
                baslangicSatiri = sonToplamSatiri + 1
            End If
        Else
            baslangicSatiri = sonToplamSatiri + 1
        End If
    End If
    
    For i = 213 To 222
        If Trim(wsKaynak.Cells(i, "J").Value) <> "" Or _
           Trim(wsKaynak.Cells(i, "M").Value) <> "" Or _
           Trim(wsKaynak.Cells(i, "N").Value) <> "" Then
            veriSatirlari.Add i
        End If
    Next i
    
    If veriSatirlari.Count > 0 Then
        wsHedef.Range(wsHedef.Cells(baslangicSatiri, "D"), _
                      wsHedef.Cells(baslangicSatiri + veriSatirlari.Count - 1, "G")).ClearContents
    End If
    
    hedefSatir = baslangicSatiri

    For Each i In veriSatirlari
        wsHedef.Cells(hedefSatir, "D").Value = wsKaynak.Range("H3").Value    ' Tarih sadece dolu satıra gelir
        wsHedef.Cells(hedefSatir, "E").Value = wsKaynak.Cells(i, "J").Value
        wsHedef.Cells(hedefSatir, "F").Value = wsKaynak.Cells(i, "M").Value
        wsHedef.Cells(hedefSatir, "G").Value = wsKaynak.Cells(i, "N").Value
        hedefSatir = hedefSatir + 1
    Next i
    
    wsHedef.Cells(hedefSatir, "J").Value = m3ToplamYeni
    wsHedef.Cells(hedefSatir, "K").Value = sterToplamYeni

    MsgBox "Veriler başarıyla aktarıldı.", vbInformation
    Exit Sub
Hata:
    MsgBox "Hata oluştu: " & Err.Description, vbCritical

End Sub

 

[Hsn55]

Sayın Muhasebeci bey çok teşekkür ederim.
1-Boş olan satırları aktarmaması gerekiyor.
2- Veri Girişi sayfasında m223 ve n223 hücrelerinde veri aynı ise ikinci kez aktarma yapmak istediğimde aktarmayacak. Farklı ise 1bir sonraki satıra aktaracak

 

[muhasebeciyiz]

Düzenledim 2 nolu mesaja bakınız

 

[Hsn55]

Hocam verileri değiştirmeme rağmen 2.kez aktardığımda 6 satır atlayarak tekrar aktarıyor. Oysaki verilerin hiç birini değiştirmedim

 

[muhasebeciyiz]

Düzenledim 7 nolu mesaja bakınız

 

[muhasebeciyiz]

Sub VeriAktar_Nakliyat()

    Dim wsKaynak As Worksheet
    Dim wsHedef As Worksheet
    Dim m3ToplamYeni As Double, sterToplamYeni As Double
    Dim m3ToplamOnceki As Double, sterToplamOnceki As Double
    Dim baslangicSatiri As Long
    Dim i As Long
    Dim sonToplamSatiri As Long
    Dim tarihSatiri As Long
  
    On Error GoTo Hata
  
    Set wsKaynak = ThisWorkbook.Sheets("ÖLÇÜ TESPİT TUTANAĞI")
    Set wsHedef = ThisWorkbook.Sheets("NAKLİYAT")
  
    If Not IsNumeric(wsKaynak.Range("M223").Value) Or Not IsNumeric(wsKaynak.Range("N223").Value) Then
        MsgBox "M223 veya N223 hücreleri geçerli sayı içermiyor!", vbCritical
        Exit Sub
    End If
  
    m3ToplamYeni = wsKaynak.Range("M223").Value
    sterToplamYeni = wsKaynak.Range("N223").Value
  
    sonToplamSatiri = wsHedef.Cells(wsHedef.Rows.Count, "J").End(xlUp).Row
  
    If sonToplamSatiri < 10 Then
        baslangicSatiri = 10
    Else
        If IsNumeric(wsHedef.Cells(sonToplamSatiri, "J").Value) And IsNumeric(wsHedef.Cells(sonToplamSatiri, "K").Value) Then
            m3ToplamOnceki = wsHedef.Cells(sonToplamSatiri, "J").Value
            sterToplamOnceki = wsHedef.Cells(sonToplamSatiri, "K").Value
          
            If m3ToplamYeni = m3ToplamOnceki And sterToplamYeni = sterToplamOnceki Then
                baslangicSatiri = sonToplamSatiri - 10
                If baslangicSatiri < 10 Then baslangicSatiri = 10
            Else
                baslangicSatiri = sonToplamSatiri + 1
            End If
        Else
            baslangicSatiri = sonToplamSatiri + 1
        End If
    End If
  
    For i = 0 To 9
        wsHedef.Cells(baslangicSatiri + i, "D").Value = wsKaynak.Range("H3").Value
    Next i
    
    For i = 0 To 9
        If wsHedef.Cells(baslangicSatiri + i, "E").Value = "" Then
            wsHedef.Cells(baslangicSatiri + i, "E").Value = wsKaynak.Cells(213 + i, "J").Value
        End If
    Next i
  
    For i = 0 To 9
        If wsHedef.Cells(baslangicSatiri + i, "F").Value = "" Then
            wsHedef.Cells(baslangicSatiri + i, "F").Value = wsKaynak.Cells(213 + i, "M").Value
        End If
    Next i
  
    For i = 0 To 9
        If wsHedef.Cells(baslangicSatiri + i, "G").Value = "" Then
            wsHedef.Cells(baslangicSatiri + i, "G").Value = wsKaynak.Cells(213 + i, "N").Value
        End If
    Next i
    
    wsHedef.Cells(baslangicSatiri + 10, "Z").Value = m3ToplamYeni
    wsHedef.Cells(baslangicSatiri + 10, "AA").Value = sterToplamYeni

    MsgBox "Veriler başarıyla aktarıldı.", vbInformation
    Exit Sub

Hata:
    MsgBox "Bir hata oluştu: " & Err.Description, vbCritical
End Sub

Ölçü tesbit tutanğı sayfasının kod bölümüne ekleyiniz.2 ve 7 nolu mesajları tekrar ikiisnide deneyip geri dönüş yapınız.

 

[Hsn55]

Boş olan satırlara da tarih atıyor. Ayrıca m3 ve ster toplamını J ve K süunlarına atıyor. Buralar boş olması gerekiyor. Çünkü buralarda başka veriler olcak

 

[muhasebeciyiz]

ilk sayfadaki j213 ve j222 arasındaki boş hücrelerdeki dizi formülleri silip aktarım yapabilirsiniz.O vakit düzgün aktarım olmaktadır