EXCEL TABLODAN VERİ ÇEKME

[anılkayı9]

Elimde büyük bir tablo var bu tablonun içinden proje numarası ile parça bilgileri çekeceğiz ama aynı proje numarası ile farklı parçalar bulunmakta. Bazı proje numarasından 3 tane varken bazı proje numarasından 5 tane veya 1 tane olabiliyor değişkenlik gösteriyor. Bizim yaptığımız bir makro bulunmakta ama sadece tek bir satırdan çekiyor ve hepsini aynı kopyalıyor. Bunu bir döngü içinde tekrar alt satıra geçirebilir miyiz veya başka bir yolu var mıdır?

Sub AKTARMA()
'
' AKTARMA Makro
Dim satir As String
Dim cinsi As String
Dim hedef As String
Dim cap As String
Dim gen As String
Dim uzun As String
Dim tipi As String
Dim cinsi2 As String
Dim adet As String


satir = Worksheets("projeler").Range("A:A").Find(Worksheets("SATIN ALMA").Range("L1").Value).Row
cinsi = Worksheets("projeler").Cells(satir, 9)
cap = Worksheets("projeler").Cells(satir, 10)
gen = Worksheets("projeler").Cells(satir, 11)
uzun = Worksheets("projeler").Cells(satir, 12)
tipi = Worksheets("projeler").Cells(satir, 15)
cinsi2 = Worksheets("projeler").Cells(satir, 16)
adet = Worksheets("projeler").Cells(satir, 6)
hedef = Worksheets("SATIN ALMA").Range("A2")
'Range("a2") = cinsi & cap & gen



Range("b1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = cinsi
Range("c1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = cap

Range("d1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = gen

Range("e1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = uzun

Range("f1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = tipi
Range("g1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = cinsi2

Range("a1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell = adet


'
End Sub

 

[Ömer]

Merhaba,

Sorunuzu örnek bir dosya ekleyerek detaylı açıklar mısınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz.

dosya.co

.

 

[anılkayı9]

Merhaba,

Sorunuzu örnek bir dosya ekleyerek detaylı açıklar mısınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz.

dosya.co

.

İstediğiniz örnek dosya ektedir.

İndir örnek dosya

Dosyayı indir örnek dosya

dosya.co

 

[Ömer]

Merhaba,

H ve I sütunlarına veri alınmıyor sanırım.
Deneyiniz.

Sub Proje_Bul()
     
    Dim Sp As Worksheet, c As Range, Adr As String, sat As Long
   
    Set Sp = Sheets("PROJELER")
   
    Application.ScreenUpdating = False
    Sheets("SATIN ALMA").Select
    Range("A2:G" & Rows.Count).ClearContents
   
    sat = 2
    Set c = Sp.[A:A].Find([L1], , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            Cells(sat, "A") = Sp.Cells(c.Row, "F")
            Cells(sat, "B") = Sp.Cells(c.Row, "I")
            Cells(sat, "C") = Sp.Cells(c.Row, "J")
            Cells(sat, "D") = Sp.Cells(c.Row, "K")
            Cells(sat, "E") = Sp.Cells(c.Row, "L")
            Cells(sat, "F") = Sp.Cells(c.Row, "O")
            Cells(sat, "G") = Sp.Cells(c.Row, "P")
            sat = sat + 1
            Set c = Sp.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
   
End Sub

 

[anılkayı9]

Merhaba,

H ve I sütunlarına veri alınmıyor sanırım.
Deneyiniz.

Sub Proje_Bul()
    
    Dim Sp As Worksheet, c As Range, Adr As String, sat As Long
  
    Set Sp = Sheets("PROJELER")
  
    Application.ScreenUpdating = False
    Sheets("SATIN ALMA").Select
    Range("A2:G" & Rows.Count).ClearContents
  
    sat = 2
    Set c = Sp.[A:A].Find([L1], , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            Cells(sat, "A") = Sp.Cells(c.Row, "F")
            Cells(sat, "B") = Sp.Cells(c.Row, "I")
            Cells(sat, "C") = Sp.Cells(c.Row, "J")
            Cells(sat, "D") = Sp.Cells(c.Row, "K")
            Cells(sat, "E") = Sp.Cells(c.Row, "L")
            Cells(sat, "F") = Sp.Cells(c.Row, "O")
            Cells(sat, "G") = Sp.Cells(c.Row, "P")
            sat = sat + 1
            Set c = Sp.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
  
End Sub

Attığınız makro çalışmıştır. Çok teşekkür ederim. İyi çalışmalar..