Skip to main content

AccessTr.neT


Excelde İki Satır Arasına Vba İle Kayıt Ekleme

Excelde İki Satır Arasına Vba İle Kayıt Ekleme

#7
Sayın feraz: aynı hata son çalışmada da oluyor. özür dilerim kafa karışıklığı yaratmasın diye bazı şeyleri çıkararak konu sayfasına eklemiştim dosyayı. oda hatalara neden oldu. tekrar özür dilerim

eksik çalışma sayfasını ve deneme çalışma sayfasındaki eksik sütunu ekleyerek tekrar ekliyorum.


Aktar2() modülünde
sayBul = 0
With ThisWorkbook.Worksheets("deneme")

satırı var. bu şekilde çok çalışma sayfası olacak? hepsini bu kod nasıl uyacak acaba. yeni sayfa kopyalayınca kod hata veriyor. her sayfa eklediğimizde bu kısmı değiştirmek mi gerekecek?

saygılar.
.rar deneme çalışma dizi.rar (Dosya Boyutu: 74,63 KB | İndirme Sayısı: 2)
hnakis, 15-10-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 26/11/2023, 03:03, Düzenleyen: hnakis.
Cevapla
#8
Abey kodları düzenlemiştim ve Aktar sub kodunuda ayarlamıştım bir deneyin dictionary ile yaptım.Sizin eklediğinizdosyayada bakarm.
Birde siz dosyayı indirmişsiniz ama ben sonradan güncelleyip tekrar eklemiştim 6.Mesajda.

Kod:
Sub Aktar(ByVal syf As Worksheet)
    Dim bul, ara As Range, i As Integer, dic As Object, aranan As String

    Set dic = CreateObject("Scripting.dictionary")
    With ThisWorkbook.Worksheets("Kimya")
        For i = 4 To 18
            bul = Application.Match(syf.Cells(i, "B").Value2, .Range("C:C"), 0)
            If Not IsError(bul) Then
                'içerik eklenirse burdan tekrar düzenle
                For Each ara In .Range("I" & bul & ":BU" & bul)
                    If Len(Trim(ara.Value)) > 0 Then
                        aranan = .Cells(2, ara.Column).Value
                        If Not dic.exists(aranan) Then dic(aranan) = 0
                    End If
                Next
            End If
        Next
    End With
    If dic.Count > 0 Then syf.Range("G3").Resize(, dic.Count).Value = dic.keys
    Set dic = Nothing
End Sub

Sub Aktar2(ByVal syf As Worksheet)
        Dim bulW_W, bulPH, sayBul As Integer, sonToplam As Integer, sonSutunG As Integer
       
        sayBul = 0
        With syf
            sonToplam = .Cells(Rows.Count, "E").End(3).Row 'E sütuna göre son satir no
            bulW_W = Application.Match("w / w", .Range("D:D"), 0)
            bulPH = Application.Match("pH", .Range("B:B"), 0)
            If IsError(bulW_W) Then Exit Sub
            If IsError(bulPH) Then Exit Sub
            If WorksheetFunction.CountA(.Range("G" & sonToplam & ":XFD" & sonToplam)) = 0 Then Exit Sub
           
            Application.EnableEvents = False
            Application.ScreenUpdating = False
           
            If bulPH - bulW_W > 1 Then .Range(.Cells(bulW_W + 1, 1), .Cells(bulPH - 1, 1)).EntireRow.Delete
            sonSutunG = .Cells(sonToplam, Columns.Count).End(xlToLeft).Column
            If sonSutunG < 7 Then GoTo sonSub
            ReDim arrBekle(1 To 3, 1 To 1)
            For i = 7 To sonSutunG 'F sütun
                If .Cells(sonToplam, i).Value2 > 0 Then
                    sayBul = sayBul + 1
                    ReDim Preserve arrBekle(1 To 3, 1 To sayBul) '3 olma sebebi C sütunu oldugu icin
                    arrBekle(1, sayBul) = .Cells(3, i).Value
                    'arrBekle(2, sayBul) = "%"
                    arrBekle(2, sayBul) = ""
                    arrBekle(3, sayBul) = .Cells(sonToplam, i).Value
                End If
            Next
sonSub:
            If sayBul > 0 Then
                .Range("A" & bulW_W + 1).Resize(sayBul).EntireRow.Insert
                .Range("B" & bulW_W + 1).Resize(sayBul, 3).Value = Application.Transpose(arrBekle)
            End If
            Application.EnableEvents = True
            Application.ScreenUpdating = True
    End With
End Sub


(26/11/2023, 02:33)hnakis yazdı: With ThisWorkbook.Worksheets("deneme")

Son dosyada sayfa adlarına gerek kalmadı ben change koduna ekledim parametre olarak alttaki gibi.

Kod:
Aktar ActiveSheet
   Aktar2 ActiveSheet

.zip deneme çalışma.zip (Dosya Boyutu: 76,22 KB | İndirme Sayısı: 2)
Cevapla
#9
sayın feraz kod sayfa ekleyince çalışıyor. süper.

tek sorun kaldı yeni eklediğim dosyada fiyat çalışma sayfası var daha önceki dosyaya eklememiştim. bu konuda tekrar özür dilerim.

B sütununda herhangi bir seçim yapınca Ab sütunundaki Fiyat kısmındaki bilgileri de Garanti edilen içeriklere ekliyor.

Fiyat kısmının kodu ekleyeceği aklıma gelmedi. tekrar özür dilerim. çok mahcup oldum size ve forumdaki herkese.

saygılar.
hnakis, 15-10-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 26/11/2023, 04:40, Düzenleyen: hnakis.
Cevapla
#10
birde eğer F3 hücresinde "Toplam azot" yazarsa onunda garanti edilen içerik bölümüne eklenmesi lazım. eğer F3 Boş olursa garanti edilen içerik bölümüne hiç bir şey eklenmemeli.
hnakis, 15-10-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#11
(26/11/2023, 04:40)hnakis yazdı: birde eğer F3 hücresinde "Toplam azot" yazarsa onunda garanti edilen içerik bölümüne eklenmesi lazım. eğer F3 Boş olursa garanti edilen içerik bölümüne hiç bir şey eklenmemeli.

Nasıl olduğunu çözemedim ama bu hata düzeldi.

merak ettiğim bir konu var. F3:Y3 arasında hücrelerinde görünen metinler belli bir sıraya göre gelebilir mi?
yada Garanti edilen içerik bölümüne eklenen metinler belli bir sırayla eklenebilir mi?

F3:Y3 arasında "Organik madde" varsa 1.sıraya gelsin, 2. sıraya "Organik Karbon" gelsin, 3.sıraya "Toplam Azot" gelsin, "Organik madde" veya "Organik Karbon" yoksa olmayan metnin yerine "Toplam Azot" vs gibi.
hnakis, 15-10-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#12
(26/11/2023, 03:47)hnakis yazdı: fiyat çalışma sayfası var daha önceki dosyaya eklememiştim.
Bu şekilde son halini ekleyin bakayım abey.

Yada yeni bir konu açın orda bakalım.Konu dağılıyor.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task