• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Ara Bul yan satırlara yaz makrosu arıyorum

  • Konbuyu başlatan Konbuyu başlatan ADER_34
  • Başlangıç tarihi Başlangıç tarihi
A

ADER_34

Katılım
2 Haziran 2015
Mesajlar
349
Excel Vers. ve Dili
2010
Merhaba sayfada A sütünunda herhangi bir satırda sütün sabit herzaman tabi, ama satırlar alt satırlara doğru gidiyor EVRAK ID yazan satırı bul,(A) sütünü ve hemen karşısında B sütununda yazan
örnek =(A) EVRAK ID sütunu (B) 12252 sütununda karşısında sabit sayı değeri var, o sayıyı kopyala alt satırlarda yazan

Sıra Özellik Açıklama Miktar Birim Fiyat Durumu
bu satıra sıra no kaçtane ise kopyala yaz gibi bir makro istiyorum mümkünse herkese iyi çalışmlalar bu işlem tüm sayfada olacak iyi çalışmalar..
 
Merhaba

Bu tür sorular örnek dosya ile desteklenmediği sürece genellikle ilgi çekmez ve genellikle cevap verilmez.
Dosya paylaşım siteleri üzerinden örnek dosyada ne istediğinizi anlatıp varmak istediğiniz sonucu gösterirseniz daha kolay yanıt alırsınız.
 
dEdE' Alıntı:
Merhaba

Bu tür sorular örnek dosya ile desteklenmediği sürece genellikle ilgi çekmez ve genellikle cevap verilmez.
Dosya paylaşım siteleri üzerinden örnek dosyada ne istediğinizi anlatıp varmak istediğiniz sonucu gösterirseniz daha kolay yanıt alırsınız.
Genişletmek için tıkla ...
merhaba dosyam paylaşıyorum
EVRAK SORGU.xlsx - 11 KB
sorum şu ilgili sayfada (EVRAK ID ) yazan sayfa,, EVRAK ID yazan kısmın karşısında ki ismi al,sonra bir alt satırda SAHİP yazan kısmın karşısında ki ismi al, sonra alt satırlarda SIRA ÖZELLİK,AÇIKLAMA,MİKTAR,TEMİN DURUMU,EVRAK ID,SAHİP, TEMİN DURUMU ALANI başlıkları altında ki verileri al EVRAK ID sayfasından süzüp ayıklayıp sonra da SORGU sayfasına ilgili başlıkların altına yapıştırmasını makro kodları ile istiyorum. mümkünse teşekkürler..
 
Merhaba hayırlı akşamlar destek ekibi ve makro yazabilen arkadaşlar ekteki dosyam ii
için yardımcı olurmusunuz? Teşekkürler.
 
Merhaba hayırlı akşamlar sevgili ustalar sorunumu çözemedim yardımcı olabilirmisniz? Teşekkürler
 
Merhaba,
Örnek dosyanız için aşağıdaki kodu deneyiniz.
PHP: 
Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim eID As String, shp As String
Dim a As Long

Set s1 = Sheets("EVRAK ID ")
Set s2 = Sheets("SORGU")
ReDim dz(1 To 9, 1 To 1)
For a = 3 To s1.Cells(Rows.Count, "A").End(3).Row
    If s1.Cells(a, "A") = "Evrak ID" Then
        eID = s1.Cells(a, "B")
        shp = s1.Cells(a + 1, "B")
    ElseIf s1.Cells(a, "A") <> "" And IsNumeric(s1.Cells(a, "A")) Then
        x = x + 1
        ReDim Preserve dz(1 To 9, 1 To x)
        dz(1, x) = s1.Cells(a, "A") 'sıra
        dz(2, x) = s1.Cells(a, "B") 'özellik
        dz(3, x) = s1.Cells(a, "C") 'açıklama
        dz(4, x) = s1.Cells(a, "D") 'miktar
        dz(5, x) = s1.Cells(a, "E") 'birim
        dz(6, x) = s1.Cells(a, "F") 'temin durumu
        dz(7, x) = eID 'Evrak id
        dz(8, x) = shp 'sahip
        dz(9, x) = s1.Cells(a, "G") 'td alanı
    End If
Next
s2.Range("A2").Resize(UBound(dz, 2), UBound(dz)).Value = Application.Transpose(dz)
End Sub
 
ÖmerBey' Alıntı:
Merhaba,
Örnek dosyanız için aşağıdaki kodu deneyiniz.
PHP: 
Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim eID As String, shp As String
Dim a As Long

Set s1 = Sheets("EVRAK ID ")
Set s2 = Sheets("SORGU")
ReDim dz(1 To 9, 1 To 1)
For a = 3 To s1.Cells(Rows.Count, "A").End(3).Row
    If s1.Cells(a, "A") = "Evrak ID" Then
        eID = s1.Cells(a, "B")
        shp = s1.Cells(a + 1, "B")
    ElseIf s1.Cells(a, "A") <> "" And IsNumeric(s1.Cells(a, "A")) Then
        x = x + 1
        ReDim Preserve dz(1 To 9, 1 To x)
        dz(1, x) = s1.Cells(a, "A") 'sıra
        dz(2, x) = s1.Cells(a, "B") 'özellik
        dz(3, x) = s1.Cells(a, "C") 'açıklama
        dz(4, x) = s1.Cells(a, "D") 'miktar
        dz(5, x) = s1.Cells(a, "E") 'birim
        dz(6, x) = s1.Cells(a, "F") 'temin durumu
        dz(7, x) = eID 'Evrak id
        dz(8, x) = shp 'sahip
        dz(9, x) = s1.Cells(a, "G") 'td alanı
    End If
Next
s2.Range("A2").Resize(UBound(dz, 2), UBound(dz)).Value = Application.Transpose(dz)
End Sub
Genişletmek için tıkla ...
Merhaba ömer bey harikasınız kodlar sorunsuz çalışıyor, Allah razı olsun. sadece kodlara ek olarak bir ricam olacak, EVRAK ID sayfasında SIRA başlığı altında 1 2 3 4 diye giden satırlrdan sonra boşluk var sonraki satırları getirmesin istiyorum nasıl bir kod eklemeliyim. Teşekkürler.
 
ADER_34' Alıntı:
Merhaba ömer bey harikasınız kodlar sorunsuz çalışıyor, Allah razı olsun. sadece kodlara ek olarak bir ricam olacak, EVRAK ID sayfasında SIRA başlığı altında 1 2 3 4 diye giden satırlrdan sonra boşluk var sonraki satırları getirmesin istiyorum nasıl bir kod eklemeliyim. Teşekkürler.
Genişletmek için tıkla ...
merhabalar öncelikle hayırlı haftalar herkese, Ömer bey yazdığınız kodlara ek olarak hangi kodları eklemeliyim teşekkürler.
 
Merhaba,
Örnek dosyanızda deneme yaptığımda bahsettiğiniz sorun oluşmuyor. Kendi dosyanıza uygun bir örnek dosya paylaşırsanız üzerinde çalışılabilir.
 
Tekrar merhaba,
En son paylaştığınız dosyaya 6 numaralı mesajda paylaştığım kodu uyguladım (Lütfen siz de deneyiniz.) ve sonuç: Sizin istemediğinizi belirttiğiniz satırlar zaten listelenmiyor. Yani belirttiğiniz sorunu içeren bir dosya olmamış.
Tahmine dayalı olarak kodu, aşağıdaki şekilde güncelledim.
Deneyiniz, istediğiniz sonucu vermezse lütfen buna uygun bir dosya paylaşınız.
PHP: 
Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim eID As String, shp As String
Dim a As Long
Dim k As Double

Set s1 = Sheets("EVRAK ID ")
Set s2 = Sheets("SORGU")
ReDim dz(1 To 9, 1 To 1)
For a = 3 To s1.Cells(Rows.Count, "A").End(3).Row
    If s1.Cells(a, "A") = "Evrak ID" Then
        eID = s1.Cells(a, "B")
        shp = s1.Cells(a + 1, "B")
    ElseIf s1.Cells(a, "A") = "Sıra" Then
        k = True
    ElseIf s1.Cells(a, "A") = "" Then
        k = False
    ElseIf k = True And IsNumeric(s1.Cells(a, "A")) Then
        x = x + 1
        ReDim Preserve dz(1 To 9, 1 To x)
        dz(1, x) = s1.Cells(a, "A") 'sıra
        dz(2, x) = s1.Cells(a, "B") 'özellik
        dz(3, x) = s1.Cells(a, "C") 'açıklama
        dz(4, x) = s1.Cells(a, "D") 'miktar
        dz(5, x) = s1.Cells(a, "E") 'birim
        dz(6, x) = s1.Cells(a, "F") 'temin durumu
        dz(7, x) = eID 'Evrak id
        dz(8, x) = shp 'sahip
        dz(9, x) = s1.Cells(a, "G") 'td alanı
    End If
Next
s2.Range("A2").Resize(UBound(dz, 2), UBound(dz)).Value = Application.Transpose(dz)
End Sub
 
ÖmerBey' Alıntı:
Tekrar merhaba,
En son paylaştığınız dosyaya 6 numaralı mesajda paylaştığım kodu uyguladım (Lütfen siz de deneyiniz.) ve sonuç: Sizin istemediğinizi belirttiğiniz satırlar zaten listelenmiyor. Yani belirttiğiniz sorunu içeren bir dosya olmamış.
Tahmine dayalı olarak kodu, aşağıdaki şekilde güncelledim.
Deneyiniz, istediğiniz sonucu vermezse lütfen buna uygun bir dosya paylaşınız.
PHP: 
Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim eID As String, shp As String
Dim a As Long
Dim k As Double

Set s1 = Sheets("EVRAK ID ")
Set s2 = Sheets("SORGU")
ReDim dz(1 To 9, 1 To 1)
For a = 3 To s1.Cells(Rows.Count, "A").End(3).Row
    If s1.Cells(a, "A") = "Evrak ID" Then
        eID = s1.Cells(a, "B")
        shp = s1.Cells(a + 1, "B")
    ElseIf s1.Cells(a, "A") = "Sıra" Then
        k = True
    ElseIf s1.Cells(a, "A") = "" Then
        k = False
    ElseIf k = True And IsNumeric(s1.Cells(a, "A")) Then
        x = x + 1
        ReDim Preserve dz(1 To 9, 1 To x)
        dz(1, x) = s1.Cells(a, "A") 'sıra
        dz(2, x) = s1.Cells(a, "B") 'özellik
        dz(3, x) = s1.Cells(a, "C") 'açıklama
        dz(4, x) = s1.Cells(a, "D") 'miktar
        dz(5, x) = s1.Cells(a, "E") 'birim
        dz(6, x) = s1.Cells(a, "F") 'temin durumu
        dz(7, x) = eID 'Evrak id
        dz(8, x) = shp 'sahip
        dz(9, x) = s1.Cells(a, "G") 'td alanı
    End If
Next
s2.Range("A2").Resize(UBound(dz, 2), UBound(dz)).Value = Application.Transpose(dz)
End Sub
Genişletmek için tıkla ...
Ömer Bey kodlar harika çalışıyor,Allah razı olsun çok teşekkür ederim bu konu çözüldü.hayırlı günler hayırlı işleriniz olsun..
 
Rica ederim,
Allah hepimizden razı olsun,
İyi çalışmalar...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst