Offsset tekniği ile makro ihtiyacı.

[Carpintero]

Merhabalar;
makrodan az biraz da olsa anlamakla beraber
bir türlü doğru sonucu aldıramadığım dosya için
yardımlarınızı talep ediyorum.

Açıklama
Veri alanımız aşağıdaki Tablo 1 Tablo 2 ve Tablo 3Makro ile Mavi verileri elde edeceğiz.F kolonundaki yeşil kutucuğun içindeki Değeri E kolonundayazan tablonun içinde arayacağız.Bulduğumuz verinin 49 dan büyük olması lazım.Bulduğumuz verlerin altındaki text ile yazılan sayılar iseC kolonunda ki bulunanların karşılıklarıTek bir makro olur ise tercih sebebidir.Üç ayrı makro da olur ise başımın üstünde yeri var.Saygılarımla.

Dosya Linki

https://www.dosyaupload.com/rcpT

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Link:
https://dosya.co/zgyvbkz6w7te/Carpintero-tablo_analiz.rar.html

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Tablolarda_Ara()
    Dim Tablo1 As Range, Tablo2 As Range, Tablo3 As Range, Alan As Range
    Dim X As Long, Bul As Range, Y As Long, Sutun As Integer

    Set Tablo1 = Range("D17:H27")
    Set Tablo2 = Range("K17:O27")
    Set Tablo3 = Range("R17:V27")
        
    Range("G2:M11").ClearContents
    
    For X = 3 To 11 Step 4
        Sutun = 7
        
        Select Case Cells(X, "E")
            Case "Tablo 1"
                Set Alan = Tablo1
            Case "Tablo 2"
                Set Alan = Tablo2
            Case "Tablo 3"
                Set Alan = Tablo3
        End Select
        
        Set Bul = Alan.Find(Cells(X, "F"), , , xlWhole)
        If Not Bul Is Nothing Then
            For Y = Alan.Cells(1, 1).Row - 16 + 4 To Alan.Cells(Alan.Rows.Count, 1).Row - 16
                If Alan.Cells(Y, Bul.Column - Alan.Column + 1) > 49 Then
                    Cells(X - 1, Sutun) = Cells(Y + 16, "C").Value
                    Cells(X, Sutun) = Alan.Cells(Y, Bul.Column - Alan.Column + 1).Value
                    Sutun = Sutun + 1
                End If
            Next
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Carpintero]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Link:
https://dosya.co/zgyvbkz6w7te/Carpintero-tablo_analiz.rar.html

muygun hocam konuya göstermiş olduğunuz ilgi için teşekkür ederim.
Sanırım şuan boş dönüyor makro
F3 F7 ve F11 değerlerine bakarak.
mavi renkli değerlerin tamamını makro üretmeli.

 

[Carpintero]

Alternatif;

Option Explicit

Sub Tablolarda_Ara()
    Dim Tablo1 As Range, Tablo2 As Range, Tablo3 As Range, Alan As Range
    Dim X As Long, Bul As Range, Y As Long, Sutun As Integer

    Set Tablo1 = Range("D17:H27")
    Set Tablo2 = Range("K17:O27")
    Set Tablo3 = Range("R17:V27")
       
    Range("G2:M11").ClearContents
   
    For X = 3 To 11 Step 4
        Sutun = 7
       
        Select Case Cells(X, "E")
            Case "Tablo 1"
                Set Alan = Tablo1
            Case "Tablo 2"
                Set Alan = Tablo2
            Case "Tablo 3"
                Set Alan = Tablo3
        End Select
       
        Set Bul = Alan.Find(Cells(X, "F"), , , xlWhole)
        If Not Bul Is Nothing Then
            For Y = Alan.Cells(1, 1).Row - 16 + 4 To Alan.Cells(Alan.Rows.Count, 1).Row - 16
                If Alan.Cells(Y, Bul.Column - Alan.Column + 1) > 49 Then
                    Cells(X - 1, Sutun) = Cells(Y + 16, "C").Value
                    Cells(X, Sutun) = Alan.Cells(Y, Bul.Column - Alan.Column + 1).Value
                    Sutun = Sutun + 1
                End If
            Next
        End If
    Next
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Hocam çok teşekkür ederim.
makro tam da istenileni yapıyor.
Eksik olmayın iyi ki varsınız.

 

[veyselemre]

Sub test()
    Range("G2:IV11").ClearContents
    Dim t(0 To 2) As Range, ref(0 To 2) As Range
    Set t(0) = Range("D21:H27")
    Set t(1) = Range("K21:O27")
    Set t(2) = Range("R21:V27")

    Set ref(0) = Range("F3")
    Set ref(1) = Range("F7")
    Set ref(2) = Range("F11")

    g = Application.Index(Range("D17:H17").Value, , 0)
    f = Application.Transpose(Range("C21:C27").Value)

    For i = 0 To 2
        sut = 1
        lst = t(i).Value
        sira = WorksheetFunction.Match(ref(i).Value, g)
        For ii = 1 To 7
            If lst(ii, sira) > 49 Then
                ref(i).Offset(-1, sut) = lst(ii, sira)
                ref(i).Offset(, sut) = f(ii)
                sut = sut + 1
            End If
        Next ii
    Next i

    MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[Carpintero]

Sayın veyselemre;
cevabınız için çok çok teşekkür ederim.
Gayet güzel bir makro da siz yazmışsınız.
Elinize yüreğinize sağlık.