Aynı excel dosyası içerisinden veri getirme

[Tekno_robotqw]

Değerli Excel Üstadları Merhaba;

Basit bir şekilde exceldeki sayfadan veri almak istiyorum fakat bir türlü sonuca varamadım, bu nedenle yardımınıza ihtiyacım var.

Data sekmesinde bir tablom var. Buradaki bilgileri Veri sekmesinde oluşturduğum tabloya formülle çekmek istiyorum. Veri sekmesinde örnek olarak bilgileri manuel yazdığım bir tablo var. Hemen yanındaki tabloya formül ile işlem yapmak istiyorum.

Veri sekmesindeki Formül tablom için;




Öncelikli olarak Data sekmesinde Kalite 1 olan birimin Hacim ve M miktarını almak istiyorum
Daha sonra aynı şekilde kalite 2 olan ürünün aynı bilgilerini çekmek istiyorum. Arada boş satırlarda var.

 

[cemshan]

Bu işlemi düşey ara ile çok rahat yapabilirsiniz. Ancak Veri (Data dosyanızı biraz düzenlemeniz gerekiyor ) Neyi nere göre getirilecek net değil.

 

[Tekno_robotqw]

Bu işlemi düşey ara ile çok rahat yapabilirsiniz. Ancak Veri (Data dosyanızı biraz düzenlemeniz gerekiyor ) Neyi nere göre getirilecek net değil.

Evet tablo biraz karmaşık fakat ana dosyayı bozamıyorum veya değiştiremiyorum. Çünkü değiştirdiğim zaman asıl dosyada çok fazla makro ve formül baştan yapılması gerek.

Önce kalite satırında kalite 1 yazanı dikkate alacağız. Daha sonra Kalite 1 e ait olan Hacim ve M değerlerini almam gerekiyor.
Sonra kalite 2 için aynı işlem vs
Kısaca bu şekidle

 

[Tekno_robotqw]

Konu günceldir. Yardım rica ederim.

 

[Korhan Ayhan]

Makroyla çözüm daha uygun görünüyor..

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Long
    Dim Last_Row As Long, No As Long
    
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Veri")
    
    Last_Row = 20
    
    ReDim Liste(1 To Last_Row * 5, 1 To 4)
    
    For Y = 2 To S1.Cells(3, S1.Columns.Count).End(1).Column
        For X = 4 To Last_Row
            If S1.Cells(X, Y).Value <> "" Then
                No = No + 1
                Liste(No, 1) = S1.Cells(2, 9).Value
                Liste(No, 2) = S1.Cells(X, 1).Value
                Liste(No, 3) = S1.Cells(2, Y).Value
                Liste(No, 4) = S1.Cells(X, Y).Value
            End If
        Next
    Next
    
    S2.Range("G2").Resize(No, 4) = Liste
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Tekno_robotqw]

Makroyla çözüm daha uygun görünüyor..

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Long
    Dim Last_Row As Long, No As Long
  
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Veri")
  
    Last_Row = 20
  
    ReDim Liste(1 To Last_Row * 5, 1 To 4)
  
    For Y = 2 To S1.Cells(3, S1.Columns.Count).End(1).Column
        For X = 4 To Last_Row
            If S1.Cells(X, Y).Value <> "" Then
                No = No + 1
                Liste(No, 1) = S1.Cells(2, 9).Value
                Liste(No, 2) = S1.Cells(X, 1).Value
                Liste(No, 3) = S1.Cells(2, Y).Value
                Liste(No, 4) = S1.Cells(X, Y).Value
            End If
        Next
    Next
  
    S2.Range("G2").Resize(No, 4) = Liste
  
    Set S1 = Nothing
    Set S2 = Nothing
  
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Sorunsuz çalışmaktadır teşekkür ediyorum.
Sadece bir kısım eksik kaldı
Örneğin bu kırmızı ile işaretlediğim hücreler boş, buralara veri geldiğinde de otomatik diğer tarafa geçmesi için koda nasıl bir ekleme yapmam lazım.
Yani B2 ve F2 sütunları arasında her zaman dolu hücreleri algılamasını istiyorum.

 

[Korhan Ayhan]

Makroyu yeniden çalıştırırsanız listeniz güncellenecektir.

 

[Tekno_robotqw]

Makroyla çözüm daha uygun görünüyor..

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Long
    Dim Last_Row As Long, No As Long
   
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Veri")
   
    Last_Row = 20
   
    ReDim Liste(1 To Last_Row * 5, 1 To 4)
   
    For Y = 2 To S1.Cells(3, S1.Columns.Count).End(1).Column
        For X = 4 To Last_Row
            If S1.Cells(X, Y).Value <> "" Then
                No = No + 1
                Liste(No, 1) = S1.Cells(2, 9).Value
                Liste(No, 2) = S1.Cells(X, 1).Value
                Liste(No, 3) = S1.Cells(2, Y).Value
                Liste(No, 4) = S1.Cells(X, Y).Value
            End If
        Next
    Next
   
    S2.Range("G2").Resize(No, 4) = Liste
   
    Set S1 = Nothing
    Set S2 = Nothing
   
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

buranın konumu I10 olarak değiştirmek istiyorum. Kod içerisinde hangi alanda değişiklik yapmam gerekiyor.
Teşekkürler

 

[Korhan Ayhan]

Liste(No, 1) = S1.Cells(2, 9).Value

2 değerini 10 yaparak deneyiniz.