İşletmedeki Sığır Listelerini Tek Bir Veri Tablosuna Dönüştürme

[bayhekim81]

Tablo1, Tablo2'ye makro ile dönüştürülebilir mi?

 

[veyselemre]

Sub duzenle()
    Application.ScreenUpdating = False
    Sheets(1).Copy
    Set wb = ActiveWorkbook
    [1:12].Delete
    Cells.MergeCells = False
    For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Cells(i, 1) Like "*Aşağıda*" Or Cells(i, 1) Like "*İŞL.ADRESİ*" Then
            Cells(i, 1) = ""
        End If
    Next i

    Set Sec = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
    If WorksheetFunction.CountBlank(Sec) > 0 Then Sec.SpecialCells(4).EntireRow.Delete

    Range("R:V,P:P,L:N,J:J,D:G,B:B").Delete Shift:=xlToLeft

    For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Cells(i, 1) = "İŞLETME NO" Then
            islNo = Trim(Mid(Cells(i, "B").Value, 2))
            islTip = Trim(Mid(Cells(i, "G").Value, 2))
            bol = Split(Trim(Mid(Cells(i + 1, "B").Value, 2)), "-")
            tc = bol(0)
            islSahibi = bol(1)
            babaAd = Trim(Mid(Cells(i + 1, "G").Value, 2))
            Cells(i, 1).Resize(3).ClearContents
            Cells(i + 3, "G").Value = islNo
            Cells(i + 3, "H").Value = islSahibi
            Cells(i + 3, "I").Value = tc
            Cells(i + 3, "J").Value = babaAd
            Cells(i + 3, "K").Value = islTip
        End If
    Next i

    Set Sec = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
    If WorksheetFunction.CountBlank(Sec) > 0 Then Sec.SpecialCells(4).EntireRow.Delete
    [A:B].Delete

    With Range("A1:I" & Cells(Rows.Count, 1).End(3).Row)
        .Font.Name = "Calibri"
        .Font.Size = 11
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .HorizontalAlignment = xlLeft
        .Copy
    End With
    [a1].PasteSpecial Paste:=xlPasteValues

    [A1:I1].Insert Shift:=xlDown
    
    With [A1:I1]
        .Value = Array("KÜPE NO", "CİNSİYET", "IRK", "DOĞ. TARİHİ", "İŞLETME NO", "İŞL.SAHİBİ", "TC NO", "BABA ADI", "İŞLETME TİPİ")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With

    With Cells
        .ColumnWidth = 100
        .EntireRow.AutoFit
        .ColumnWidth = 2
        .EntireColumn.AutoFit
    End With

    Application.ScreenUpdating = True


End Sub

 

[hakanimamoglu]

Gerçekten süper elinize sağlık

 

[YUSUF44]

Ben de aşağıdaki gibi bir makro hazırlamıştım. Öncesinde Asıl dosyanızda yani işletmedeki hayvan bilgisi raporu dosyanızda Sayfa1 isimli yeni bir sayfa ekleyip ikinci dosyanzıdaki başlık satırını bu boş sayfaya kopyalayın. Aşağıdaki kodları bir modüle kopyalayıp deneyin:

Sub Turkvet()
son = Cells(Rows.Count, "H").End(3).Row
yeni = 2
For işletme = 13 To son
If Left(Cells(işletme, "C"), 4) = ": TR" Then
    For küpe = işletme + 7 To Cells(işletme + 2, "C").End(xlDown).Row - 2
        If Cells(küpe, "I") = "DİŞİ" Or Cells(küpe, "I") = "ERKEK" Then
            Sheets("Sayfa1").Cells(yeni, "A") = Cells(küpe, "H")
            Sheets("Sayfa1").Cells(yeni, "B") = Cells(küpe, "I")
            Sheets("Sayfa1").Cells(yeni, "C") = Cells(küpe, "K")
            Sheets("Sayfa1").Cells(yeni, "D") = Cells(küpe, "O")
            Sheets("Sayfa1").Cells(yeni, "E") = Replace(Cells(işletme, "C"), ": ", "")
            Sheets("Sayfa1").Cells(yeni, "F") = Mid(Cells(işletme + 1, "C"), WorksheetFunction.Find("-", Cells(işletme + 1, "C")) + 1, _
                Len(Cells(işletme + 1, "C")) - WorksheetFunction.Find("-", Cells(işletme + 1, "C")))
            Sheets("Sayfa1").Cells(yeni, "G") = Mid(Cells(işletme + 1, "C"), 3, WorksheetFunction.Find("-", Cells(işletme + 1, "C")) - 3)
            Sheets("Sayfa1").Cells(yeni, "H") = Replace(Cells(işletme + 1, "Q"), ": ", "")
            Sheets("Sayfa1").Cells(yeni, "I") = Replace(Cells(işletme, "Q"), ": ", "")
            yeni = yeni + 1
        End If
    Next
    işletme = küpe
End If
Next
        
End Sub

 

[bayhekim81]

İnanamıyorum harika, teşşekürler