Excelde sayfadan sayfaya veri aktarımı

[morfiss]

Merhaba,

Ekteki örnek dosyada bulunan yevmiye ve kebir kısmına data1 ve data 2 den renklerle işaretli alanların aktarılması gerekiyor.Data dosyası 30.000 satır civarında ve düzenli değil.Örnekte hangi verinin datanın neresinden geldiği işaretlendi.Buna uygun bi formül yapılabilir mi ?

 

[Ömer]

Merhaba,

Module kopyalayıp ayrı ayrı çalıştırın.

Sub Yevmiye()
    Dim Sd As Worksheet, i As Long, sat As Long, a As Long, b As Long
    Dim j As Long, c As Long
    
    Set Sd = Sheets("data1")
    
    Application.ScreenUpdating = False
    Sheets("YEVMİYE").Select
    Range("A2:H" & Rows.Count).Clear
    
    For i = 5 To Sd.Cells(Rows.Count, "C").End(xlUp).Row
        If Sd.Cells(i, "C") <> "" Then
            sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
            a = i + 1
            b = Sd.Cells(a, "B").End(xlDown).Row
            Cells(sat, "A").Resize(b - a + 1, 1) = Sd.Cells(i, "B")
            Cells(sat, "B").Resize(b - a + 1, 1) = Sd.Cells(i, "C")
            Sd.Cells(a, "F").Resize(b - a + 1, 1).Copy Cells(sat, "D")
            c = 0
            For j = 1 To (b - a + 1)
                Cells(sat + c, "C") = Left(Cells(sat + c, "D"), 3)
                c = c + 1
            Next j
            Sd.Cells(a, "B").Resize(b - a + 1, 1).Copy Cells(sat, "E")
            Sd.Cells(a, "K").Resize(b - a + 1, 1).Copy Cells(sat, "F")
            Sd.Cells(a, "P").Resize(b - a + 1, 2).Copy Cells(sat, "G")
        End If
    Next i
End Sub

Sub Kebir()
    Dim Sd As Worksheet, i As Long, sat As Long
    
    Set Sd = Sheets("data2")
    
    Application.ScreenUpdating = False
    Sheets("KEBİR").Select
    Range("A2:I" & Rows.Count).Clear
    
    For i = 5 To Sd.Cells(Rows.Count, "D").End(xlUp).Row
        If IsNumeric(Sd.Cells(i, "D")) = True Then
            sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
            Cells(sat, "A") = Sd.Cells(i, "D")
            Cells(sat, "B") = Sd.Cells(i, "E")
            Cells(sat, "C") = Sd.Cells(i, "C")
            Cells(sat, "D") = Left(Sd.Cells(i, "F"), 3)
            Cells(sat, "E") = Sd.Cells(i, "F")
    [COLOR=darkolivegreen]        'Cells(sat, "F") = ?[/COLOR]
            Cells(sat, "G") = Sd.Cells(i, "G")
            Cells(sat, "H") = Sd.Cells(i, "I")
            Cells(sat, "I") = Sd.Cells(i, "J")
        End If
    Next i
End Sub

 

[morfiss]

Üstad on numarasın valla eline koluna sağlık.Büyük bir dertten kurtardın.Allah razı olsun.Reklamlara tıklayarak karşılığını ödemeye çalışacağım.