Excel Makro ile Yukarıdaki Satırlardan Bilgi getirme

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Merhaba örnek excel sayfasında bulunan (orjinal) verilere 360.09'un altına otomatik satır açıp üstteki verilerin kopyalanmasını istiyorum.Bunun için örnek bir makro çalışması yapılabilir mi. İstediğim şablon ekte yer almaktadır. Şimdiden Teşekkür ederim.:)
 

Ekli dosyalar

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
681
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
Merhaba örnek excel sayfasında bulunan (orjinal) verilere 360.09'un altına otomatik satır açıp üstteki verilerin kopyalanmasını istiyorum.Bunun için örnek bir makro çalışması yapılabilir mi. İstediğim şablon ekte yer almaktadır. Şimdiden Teşekkür ederim.:)
100.01.01 yazan yerlere 120.P.PEŞİN YAZILMASI GEREK demişssin bu kısmı anlamadım. 120.P.PEŞİN yazılacaksa o zaman sarı olan yerlerde iki tene alt alta 120.P.PEŞİN yazılı gözükecek. Çünkü sarı kısımda zaten bir tane 120.P.PEŞİN yazılı ????
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,439
Excel Vers. ve Dili
2019 Türkçe
Merhaba.
Aşağıdaki kodu bir modüle kopyalayıp çalıştırınız.
Kod:
Sub test()
    Dim Bak As Long
    Dim Borc
    Dim Alacak
    Application.ScreenUpdating = False
    For Bak = 2 To Rows.Count
        Borc = Borc + Cells(Bak, "G")
        Alacak = Alacak + Cells(Bak, "H")
        
        If Cells(Bak, "A") = "" Then
            Exit For
        Else
            If Cells(Bak, "B") = "100.01.01" Then
                Cells(Bak, "B") = "120.P.PEŞİN"
            ElseIf Cells(Bak, "B") = "360.09" Then
                Cells(Bak + 1, "B").Resize(2, 1).EntireRow.Insert
                Cells(Bak, "A").Resize(3, 6).FillDown
                Cells(Bak + 1, "B") = "100.01.01"
                Cells(Bak + 1, "G") = Borc
                Cells(Bak + 2, "B") = "120.P.PEŞİN"
                Cells(Bak + 2, "H") = Alacak
                Borc = 0
                Alacak = 0
                Bak = Bak + 2
            End If
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı."
End Sub
 
Son düzenleme:

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Merhaba.
Aşağıdaki kodu bir modüle kopyalayıp çalıştırınız.
Kod:
Sub test()
    Dim Bak As Long
    Dim Borc
    Dim Alacak
    Application.ScreenUpdating = False
    For Bak = 2 To Rows.Count
        Borc = Borc + Cells(Bak, "G")
        Alacak = Alacak + Cells(Bak, "H")
       
        If Cells(Bak, "A") = "" Then
            Exit For
        Else
            If Cells(Bak, "B") = "100.01.01" Then
                Cells(Bak, "B") = "120.P.PEŞİN"
            ElseIf Cells(Bak, "B") = "360.09" Then
                Cells(Bak + 1, "B").Resize(2, 1).EntireRow.Insert
                Cells(Bak, "A").Resize(3, 6).FillDown
                Cells(Bak + 1, "B") = "100.01.01"
                Cells(Bak + 1, "G") = Borc
                Cells(Bak + 2, "B") = "120.P.PEŞİN"
                Cells(Bak + 2, "H") = Alacak
                Borc = 0
                Alacak = 0
                Bak = Bak + 2
            End If
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı."
End Sub
Çok teşekkür ederim bu şekilde oldu
 

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Merhaba, yedek alıp şöyle deneyebilir misiniz;

Kod:
Sub satisSP_Toplu()
    Dim i As Long, Bak As Long
    Dim sonb As Long, sonSatir As Long
    Dim Borc As Double
    Dim dosyaYolu As String
  
    Application.ScreenUpdating = False
  
    Cells.Replace What:="deneme", Replacement:="deneme işlemiİ", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    Columns("E:E").Insert Shift:=xlToRight
    Columns("D:D").TextToColumns Destination:=Range("D1"), _
        DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(1, 1)), _
        TrailingMinusNumbers:=True
  
    On Error Resume Next
    ActiveSheet.Name = "SATIŞ"
    On Error GoTo 0
  
    sonb = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To sonb - 2
        If Left(Trim(Cells(i, 2).Value), 4) = "600." Then
            If Left(Trim(Cells(i + 1, 2).Value), 4) <> "600." And _
               Left(Trim(Cells(i + 2, 2).Value), 4) <> "600." Then
                Cells(i + 1, 7).Value = Cells(i, 8).Value
                Cells(i, 8).Value = Cells(i + 1, 7).Value - Cells(i + 2, 8).Value
            End If
        End If
    Next i
  
    Borc = 0
    Bak = 2
    sonSatir = Cells(Rows.Count, "A").End(xlUp).Row
  
    Do While Bak <= sonSatir
        If IsNumeric(Cells(Bak, "G").Value) Then
            Borc = Borc + Cells(Bak, "G").Value
        End If
      
        If Trim(Cells(Bak, "A").Value) = "" Then Exit Do
        Select Case Cells(Bak, "B").Value
            Case "100.01.01"
            Case "360.09"
                Cells(Bak + 1, "B").EntireRow.Insert
                Cells(Bak, "A").Resize(2, 6).FillDown
                Cells(Bak + 1, "B").Value = "120.P.PEŞİN"
                Cells(Bak + 1, "G").Value = Borc
                Borc = 0
                Bak = Bak + 1
                sonSatir = sonSatir + 1
        End Select
        Bak = Bak + 1
    Loop
    dosyaYolu = "C:\Users\Server User\Desktop\SP SATIŞ.xls"
    If Dir(dosyaYolu) <> "" Then
        If MsgBox("Dosya zaten var. Üzerine yazılsın mı?", _
                  vbYesNo + vbQuestion) = vbNo Then
            MsgBox "Kaydedilmedi.", vbExclamation
            GoTo Son
        End If
    End If
    ActiveWorkbook.SaveAs Filename:=dosyaYolu, FileFormat:=xlExcel8
  
Son:
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı!", vbInformation
End Sub
Yok olmadı bu sefer 100.01.01 değişmedi sadece 360.09 dan sonra 120.P.PEŞİN ekledi ama ordaki toplamlarda zaten tutmuyor
 

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Merhaba Excel Tablomda Orjinal hali Makro kodları aşağıdadır. Ancak 100.01.01 - 120.P.PEŞİN Sarı ile işaretlediğim yerlere yanlış veri gelmektedir. Yardımlarınızı rica ederim.

Kod:
Sub satisSP_Toplu()

    Dim i As Long, Bak As Long
    Dim sonb As Long, sonSatir As Long
    Dim Borc As Double, Alacak As Double
    Dim dosyaYolu As String

    Application.ScreenUpdating = False

    ' 1. "isim beyan edilmemistir" metnini değiştir
    Cells.Replace What:="isim beyan edilmemistir", Replacement:="DÖVİZ SATIŞ İŞLEMİ", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False

    ' 2. E sütununu ekle
    Columns("E:E").Insert Shift:=xlToRight

    ' 3. D sütununu sabit genişlikli kolona çevir
    Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True

    ' 4. Sayfa adını değiştir
    On Error Resume Next
    ActiveSheet.Name = "SATIŞ"
    On Error GoTo 0

    ' 5. "600." ile başlayan satırlarda işlem yap
    sonb = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To sonb - 2
        If Left(Trim(Cells(i, 2).Value), 4) = "600." Then
            If Left(Trim(Cells(i + 1, 2).Value), 4) <> "600." And _
               Left(Trim(Cells(i + 2, 2).Value), 4) <> "600." Then
                Cells(i + 1, 7).Value = Cells(i, 8).Value
                Cells(i, 8).Value = Cells(i + 1, 7).Value - Cells(i + 2, 8).Value
            End If
        End If
    Next i

    ' 6. "100.01.01" ve "360.09" işlemlerine göre borç-alacak satır ekleme
    Bak = 2
    sonSatir = Cells(Rows.Count, "A").End(xlUp).Row

    Do While Bak <= sonSatir
        ' Borç ve alacakları topla
        If IsNumeric(Cells(Bak, "G").Value) Then Borc = Borc + Cells(Bak, "G").Value
        If IsNumeric(Cells(Bak, "H").Value) Then Alacak = Alacak + Cells(Bak, "H").Value

        ' A sütunu boşsa işlem biter
        If Trim(Cells(Bak, "A").Value) = "" Then
            Exit Do
        Else
            ' Hesap kodu kontrolü
            If Cells(Bak, "B").Value = "100.01.01" Then
                Cells(Bak, "B").Value = "120.P.PEŞİN"

            ElseIf Cells(Bak, "B").Value = "360.09" Then
                ' 2 yeni satır ekle
                Cells(Bak + 1, "B").Resize(2, 1).EntireRow.Insert
                ' A-F sütunlarını 3 satır boyunca doldur
                Cells(Bak, "A").Resize(3, 6).FillDown
                ' Yeni satırlara değerleri yaz
                Cells(Bak + 1, "B").Value = "100.01.01"
                Cells(Bak + 1, "G").Value = Borc
                Cells(Bak + 2, "B").Value = "120.P.PEŞİN"
                Cells(Bak + 2, "H").Value = Alacak
                ' Toplamları sıfırla
                Borc = 0
                Alacak = 0
                ' İndeksi ve satır sayısını güncelle
                Bak = Bak + 2
                sonSatir = sonSatir + 2
            End If
        End If

        Bak = Bak + 1
    Loop

    ' 7. Dosyayı kaydet
    dosyaYolu = "C:\Users\Server User\Desktop\SP SATIŞ.xls"
    If Dir(dosyaYolu) <> "" Then
        If MsgBox("Dosya zaten var. Üzerine yazılsın mı?", vbYesNo + vbQuestion) = vbNo Then
            MsgBox "Kaydedilmedi.", vbExclamation
            Exit Sub
        End If
    End If

    ActiveWorkbook.SaveAs Filename:=dosyaYolu, FileFormat:=xlExcel8

    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı!", vbInformation

End Sub
 

Ekli dosyalar

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Merhaba, şu şekilde deneyebilir misiniz;

Kod:
ub satisSP_Toplu()
    Dim i As Long, Bak As Long
    Dim sonb As Long, sonSatir As Long
    Dim Borc As Double, Alacak As Double
    Dim dosyaYolu As String
    Application.ScreenUpdating = False

    Cells.Replace What:="isim beyan edilmemistir", Replacement:="DÖVİZ SATIŞ İŞLEMİ", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    Columns("E:E").Insert Shift:=xlToRight
    Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True

    On Error Resume Next
    ActiveSheet.Name = "SATIŞ"
    On Error GoTo 0

    sonb = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To sonb - 2
        If Left(Trim(Cells(i, 2).Value), 4) = "600." Then
            If Left(Trim(Cells(i + 1, 2).Value), 4) <> "600." And _
               Left(Trim(Cells(i + 2, 2).Value), 4) <> "600." Then
                Cells(i + 1, 7).Value = Cells(i, 8).Value
                Cells(i, 8).Value = Cells(i + 1, 7).Value - Cells(i + 2, 8).Value
            End If
        End If
    Next i

    Bak = 2
    sonSatir = Cells(Rows.Count, "A").End(xlUp).Row
    Do While Bak <= sonSatir
        If IsNumeric(Cells(Bak, "G").Value) Then Borc = Borc + Cells(Bak, "G").Value
        If IsNumeric(Cells(Bak, "H").Value) Then Alacak = Alacak + Cells(Bak, "H").Value

        If Trim(Cells(Bak, "A").Value) = "" Then
            Exit Do
        Else
            If Cells(Bak, "B").Value = "100.01.01" Then
                Cells(Bak, "B").Value = "120.P.PEŞİN"
            ElseIf Cells(Bak, "B").Value = "360.09" Then
                Cells(Bak + 1, "B").Resize(2, 1).EntireRow.Insert
                Cells(Bak, "A").Resize(3, 6).FillDown
                Cells(Bak + 1, "B").Value = "100.01.01"
                Cells(Bak + 1, "G").Value = Borc   
                Cells(Bak + 2, "B").Value = "120.P.PEŞİN"
                Cells(Bak + 2, "H").Value = Alacak   
                Borc = 0
                Alacak = 0
                Bak = Bak + 2
                sonSatir = sonSatir + 2
            End If
        End If
        Bak = Bak + 1
    Loop
    dosyaYolu = "C:\Users\Server User\Desktop\SP SATIŞ.xls"
    If Dir(dosyaYolu) <> "" Then
        If MsgBox("'" & dosyaYolu & "' dosyası zaten var. Üzerine yazılsın mı?", vbYesNo + vbQuestion, "Dosya Kaydetme Onayı") = vbNo Then
            MsgBox "Dosya kaydedilmedi.", vbExclamation, "Bilgi"
            Application.ScreenUpdating = True
            Exit Sub
        End If
    End If
    On Error GoTo KaydetmeHatasi
    ActiveWorkbook.SaveAs Filename:=dosyaYolu, FileFormat:=xlExcel8 ' xlExcel8 = Excel 97-2003 Çalışma Kitabı (.xls)
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı! Dosya şu yola kaydedildi: " & dosyaYolu, vbInformation, "Başarılı"
    Exit Sub

KaydetmeHatasi:
    Application.ScreenUpdating = True
    MsgBox "Dosya kaydedilirken bir hata oluştu:" & vbCrLf & Err.Description, vbCritical, "Kaydetme Hatası"
End Sub
Teşekkür ederim ilginiz için Makroyu çalıştırdığın Sarı ile işaretlediğim yerlerde yanlış toplam geliyor
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,439
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Orijinal halinde Borç ve alacak satırlarındaki değerler birbirinden farklı, Toplama kısmı yani 100.01.01 ile 120.P.PEŞİN kısmı eşitlenmesi gerekiyor

Kod:
Cells(i + 1, 7).Value = Cells(i, 8).Value
Bu kod satırı başı "600." olan "Muhkod" ile aynı yaptığından(eşitlediğinden) doğru sonuç dönmüyor.

Bu satırı silmelisiniz.
Yada bu satır ve altındaki satırı gözden geçirin.

Kodları F8 tuşuna basarak satır satır çalıştırıp dönen sonucu adım adım gözlemleyerek sorunu bulup çözebilirsiniz.
 

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Merhaba.

Orijinal halinde Borç ve alacak satırlarındaki değerler birbirinden farklı, Toplama kısmı yani 100.01.01 ile 120.P.PEŞİN kısmı eşitlenmesi gerekiyor

Kod:
Cells(i + 1, 7).Value = Cells(i, 8).Value
Bu kod satırı başı "600." olan "Muhkod" ile aynı yaptığından(eşitlediğinden) doğru sonuç dönmüyor.

Bu satırı silmelisiniz.
Yada bu satır ve altındaki satırı gözden geçirin.

Kodları F8 tuşuna basarak satır satır çalıştırıp dönen sonucu adım adım gözlemleyerek sorunu bulup çözebilirsiniz.
aslında her işlemde yukardaki 600. ve 360.09 toplamını alsa daha iyi olur
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,439
Excel Vers. ve Dili
2019 Türkçe
Bizden örnek bir kod isteyip üzerinde değişiklik yapmak istiyorsunuz kod bilginiz iyi olmadığı için çözüme ulaşamıyorsunuz.

Bunu yerine gerçek dosyanızla birebir bir dosya üzerinde tam olarak ne istediğinizi sorarsanız belki bir cevap bulabilirsiniz.
 

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Bizden örnek bir kod isteyip üzerinde değişiklik yapmak istiyorsunuz kod bilginiz iyi olmadığı için çözüme ulaşamıyorsunuz.

Bunu yerine gerçek dosyanızla birebir bir dosya üzerinde tam olarak ne istediğinizi sorarsanız belki bir cevap bulabilirsiniz.
Örnek dosya ektedir diğer makro dursun direk buna makro yapabilirseniz
 

Ekli dosyalar

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,439
Excel Vers. ve Dili
2019 Türkçe
3. mesajda yazdığım kod doğru çalışıyor. Yeni dosyada farklı olarak Alacak ve Borç sütunlarının yerlerini değiştirmişsiniz.
Kodu yeni dosyaya göre düzenledim. Dosyanız ekte.
 

Ekli dosyalar

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
3. mesajda yazdığım kod doğru çalışıyor. Yeni dosyada farklı olarak Alacak ve Borç sütunlarının yerlerini değiştirmişsiniz.
Kodu yeni dosyaya göre düzenledim. Dosyanız ekte.
Makroyu çalıştırdığım zaman 5 - 6 sütunlarında ki borç alacak doğru ama 12 - 13 ve 19 - 20 de ki sütunlar yanlış oluyor. Tekrar kontrol edebilir misiniz Orjinal sayfada sizin makronuzu çalıştırıp
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,439
Excel Vers. ve Dili
2019 Türkçe
Kodları çalıştırdıktan sonra görseldeki gibi sonuç döndü. Burada hatalı olan yer neresi?

257693
 

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Kırmızı ile işaretlediğim yerler yanlış orada yeşil ile işaretlediğim rakam gelmesi gerek
 

Ekli dosyalar

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
257699

bu şekilde olacak yani, her çizgi çektiğim işlem tek fişin muhasebe kaydı
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,439
Excel Vers. ve Dili
2019 Türkçe
Anladığım kadarıyla toplam altında kalan "920.00.000" ve "925.00.000" kodları atlanacak.
Doğru anladıysam kodlarda bulunan Bak = Bak + 2 satırındaki 2 yi 4 yapın Bak = Bak + 4 olacak
 

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
202
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Anladığım kadarıyla toplam altında kalan "920.00.000" ve "925.00.000" kodları atlanacak.
Doğru anladıysam kodlarda bulunan Bak = Bak + 2 satırındaki 2 yi 4 yapın Bak = Bak + 4 olacak
Çok Teşekkür ederim, bu şekilde düzeldi.
 
Üst