Excel Makro ile bir sayfadan diğer sayfaya veri yazdırma

[mrvctug]

Merhaba,
parça numaralarını daha hızlı anlatmak için 20 ye düşürdüm. 31 tane parça no var normalde.
tamam teşekkür ederim

 

[Necdet]

Tam zamanında bitti.
Kodları deneyiniz. Bu arada sayfa indisleri de ingilizceye dönmüş

Public Sub Deneme()

Dim sonCol As Integer
Dim i   As Long
Dim col As Integer
Dim arr As Variant
Dim c   As Range


sonCol = Sheet1.Cells(2, Columns.Count).End(1).Column

col = 4

Do Until Sheet2.Cells(3, col) = ""
    
    Set c = Sheet1.Range("B:B").Find(Sheet2.Cells(3, col), LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        Sheet2.Cells(2, col + 1) = Sheet1.Cells(c.Row, 3) 'Tarihi yazdırdık
        arr = Sheet1.Range(Sheet1.Cells(c.Row, 4), Sheet1.Cells(c.Row, sonCol)).Value
        Sheet2.Cells(5, col).Resize(UBound(arr, 2), 1) = Application.WorksheetFunction.Transpose(arr)
    End If
    
    col = col + 2
Loop

MsgBox "Listeleme Bitmiştir .....", vbInformation
End Sub

 

[mrvctug]

Merhaba,
Çok teşekkür ederim. Son bir sorum kaldı değerler - olarak geliyor ya nasıl onları + olarak getirebilirim

 

[MajorEvanss]

Merhaba! Spor verilerini Excel kullanarak analiz etmek gerçekten harika bir fikir. Excel, istatistiklerinizi düzenlemek ve görselleştirmek için güçlü bir araçtır. Dosyanızı inceledim ve size yardımcı olabilirim. Hangi verileri nasıl analiz etmek istediğinizi daha iyi anlamam için daha fazla ayrıntı verebilir misiniz? Size Excel'de nasıl ilerleyeceğinizi gösterebilirim. Kazançlar gibi farklı istatistikleri tutmak için de çok kullanışlıdır, çevrimiçi okuyun hakkında daha fazla bilgi edinebilirsiniz.

 

[Necdet]

Merhaba! Spor verilerini Excel kullanarak analiz etmek gerçekten harika bir fikir. Excel, istatistiklerinizi düzenlemek ve görselleştirmek için güçlü bir araçtır. Dosyanızı inceledim ve size yardımcı olabilirim. Hangi verileri nasıl analiz etmek istediğinizi daha iyi anlamam için daha fazla ayrıntı verebilir misiniz? Size Excel'de nasıl ilerleyeceğinizi gösterebilirim. Kazançlar gibi farklı istatistikleri tutmak için de çok kullanışlıdır, çevrimiçi okuyun hakkında daha fazla bilgi edinebilirsiniz.

?????

 

[Necdet]

Merhaba,
Çok teşekkür ederim. Son bir sorum kaldı değerler - olarak geliyor ya nasıl onları + olarak getirebilirim

Buyrun.

Public Sub Deneme()

Dim sonCol As Integer
Dim i   As Long
Dim col As Integer
Dim arr As Variant
Dim c   As Range


sonCol = Sheet1.Cells(2, Columns.Count).End(1).Column

col = 4

Do Until Sheet2.Cells(3, col) = ""
    
    Set c = Sheet1.Range("B:B").Find(Sheet2.Cells(3, col), LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        Sheet2.Cells(2, col + 1) = Sheet1.Cells(c.Row, 3) 'Tarihi yazdırdık
        arr = Sheet1.Range(Sheet1.Cells(c.Row, 4), Sheet1.Cells(c.Row, sonCol)).Value
        For i = LBound(arr, 2) To UBound(arr, 2)
            If Not arr(1, i) = "" Then arr(1, i) = Abs(arr(1, i))
        Next i
        Sheet2.Cells(5, col).Resize(UBound(arr, 2), 1) = Application.WorksheetFunction.Transpose(arr)
    End If
    
    col = col + 2
Loop

MsgBox "Listeleme Bitmiştir .....", vbInformation
End Sub

 

[mrvctug]

Merhaba Necdet Bey,
Örnek excel çalışmamda şöyle birşey yapmak mümkün mü?
Sheet1 de 31 tane part number var bu part numberlardan sonrada bişey yazılma durumu olursa diye sadece o kısmı makroda gösterilebilir mi?
Sheet2 de alt kısma da yazan değerler gelebilir mi? Excel linki atıyorum daha net anlarsınız diye düşünüyorumhttps://s6.dosya.tc/server16/xjem8u/ornekcalisma.xlsx.html

 

[mrvctug]

Merhaba,
Yardım edebilecek birisi var mı sorunuma?

 

[mrvctug]

Merhaba sorunumu çözemedim hala yardımcı olur musunuz?

 

[Necdet]

Merhaba,

Kodları yazarken baya sıkılldım.
Nedenleri :
2 değişik formatta dosya paylaştınız.
formatların hiç biri birbirine benzemiyordu.
Örneğin ilk paylaştığınız dosyada hem Türkçe hem İngilizce sayfa adları vardı,
birinci dosyanın verileri 3. satırdan başlarken ikinci dosyanın verileri 6. satırdan başlıyor vs vs vs
Dolayısıyla çok kontrol yapmak zorunda kaldım ki Sonunda Sheet1 deki irs number ların B sütununda olduğunu varsaydım.
İnşallah bunu değiştirmek zorunda kalmazsınız.
En son dosyanın Sheet2 deki 2 ayrı tablonun da birbirine uyum sağlamıyordu, ki 2. tabloyu düzeltmek zorunda kaldım.
Kısacası baya sıkıldım.
Kodları deneyiniz.
Umarım atladığım bir şey olmamıştır.

Public Sub Deneme()

Dim c As Range
Dim cc As Range
Dim adr As String
Dim i   As Long
Dim j   As Long
Dim a   As Integer
Dim col As Integer
Dim irsNumberRow As Long
Dim aranan() As String
Dim irsRow As Integer
Dim irsCol As Integer
Dim PartNumberBasNo As Integer
Dim partnumberBsCol As Integer
Dim partnumberBtCol As Integer

Application.ScreenUpdating = False

With Sheet2.Range("A:A")
    Set c = .Find("Part Number", LookIn:=xlValues)
    If Not c Is Nothing Then
        adr = c.Address
        Do
            ReDim Preserve aranan(i)
            aranan(i) = c.Address
            i = i + 1
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adr
    End If
End With

'Sheet2 deki tüm Part Number
For a = LBound(aranan) To UBound(aranan)
    col = 4
    irsRow = Range(aranan(a)).Offset(-1, 0).Row
    PartNumberBasNo = Sheet2.Range(aranan(a)).Offset(1, 0).Value
    'Part Number sheet1 de kaçıncı satırda bulunuyor
    Set c = Sheet1.Cells.Find("Part Number", LookIn:=xlValues, LookAt:=xlWhole)
    If c Is Nothing Then
        MsgBox "Sheet1 de " & """Part Number""" & " bulunmadı..."
        Exit Sub
    Else
        Set cc = Sheet1.Rows(c.Row).Find(PartNumberBasNo, LookIn:=xlValues, LookAt:=xlWhole)
        If Not cc Is Nothing Then
            partnumberBsCol = cc.Column
            partnumberBtCol = cc.End(xlToRight).Column
        End If
    End If
    
    Do Until Sheet2.Cells(irsRow, col) = ""
        'sheet2 deki irs numberların sheet1 de aranıp aktarılması
        Set c = Sheet1.Columns(2).Find(Sheet2.Cells(irsRow, col), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            irsNumberRow = c.Row
'            sheet1 de bulunan irs numberların Part No larının aktarımı
            j = irsRow + 2
'            Sheet2 ye tarihleri yazar
            Sheet2.Cells(irsRow - 1, col + 1) = Sheet1.Cells(irsNumberRow, "C")
            'tarihler yazıldı
            For i = partnumberBsCol To partnumberBtCol
                If Sheet1.Cells(irsNumberRow, i) < 0 Then
                    Sheet2.Cells(j, col) = Abs(Sheet1.Cells(irsNumberRow, i))
                Else
                    Sheet2.Cells(j, col) = Sheet1.Cells(irsNumberRow, i)
                End If
                j = j + 1
            Next i
        End If
        col = col + 2
    Loop
Next a

Application.ScreenUpdating = True

End Sub

Harici Link İçin Tıklayınız

 

[mrvctug]

Merhaba,

Kodları yazarken baya sıkılldım.
Nedenleri :
2 değişik formatta dosya paylaştınız.
formatların hiç biri birbirine benzemiyordu.
Örneğin ilk paylaştığınız dosyada hem Türkçe hem İngilizce sayfa adları vardı,
birinci dosyanın verileri 3. satırdan başlarken ikinci dosyanın verileri 6. satırdan başlıyor vs vs vs
Dolayısıyla çok kontrol yapmak zorunda kaldım ki Sonunda Sheet1 deki irs number ların B sütununda olduğunu varsaydım.
İnşallah bunu değiştirmek zorunda kalmazsınız.
En son dosyanın Sheet2 deki 2 ayrı tablonun da birbirine uyum sağlamıyordu, ki 2. tabloyu düzeltmek zorunda kaldım.
Kısacası baya sıkıldım.
Kodları deneyiniz.
Umarım atladığım bir şey olmamıştır.

Public Sub Deneme()

Dim c As Range
Dim cc As Range
Dim adr As String
Dim i   As Long
Dim j   As Long
Dim a   As Integer
Dim col As Integer
Dim irsNumberRow As Long
Dim aranan() As String
Dim irsRow As Integer
Dim irsCol As Integer
Dim PartNumberBasNo As Integer
Dim partnumberBsCol As Integer
Dim partnumberBtCol As Integer

Application.ScreenUpdating = False

With Sheet2.Range("A:A")
    Set c = .Find("Part Number", LookIn:=xlValues)
    If Not c Is Nothing Then
        adr = c.Address
        Do
            ReDim Preserve aranan(i)
            aranan(i) = c.Address
            i = i + 1
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adr
    End If
End With

'Sheet2 deki tüm Part Number
For a = LBound(aranan) To UBound(aranan)
    col = 4
    irsRow = Range(aranan(a)).Offset(-1, 0).Row
    PartNumberBasNo = Sheet2.Range(aranan(a)).Offset(1, 0).Value
    'Part Number sheet1 de kaçıncı satırda bulunuyor
    Set c = Sheet1.Cells.Find("Part Number", LookIn:=xlValues, LookAt:=xlWhole)
    If c Is Nothing Then
        MsgBox "Sheet1 de " & """Part Number""" & " bulunmadı..."
        Exit Sub
    Else
        Set cc = Sheet1.Rows(c.Row).Find(PartNumberBasNo, LookIn:=xlValues, LookAt:=xlWhole)
        If Not cc Is Nothing Then
            partnumberBsCol = cc.Column
            partnumberBtCol = cc.End(xlToRight).Column
        End If
    End If
   
    Do Until Sheet2.Cells(irsRow, col) = ""
        'sheet2 deki irs numberların sheet1 de aranıp aktarılması
        Set c = Sheet1.Columns(2).Find(Sheet2.Cells(irsRow, col), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            irsNumberRow = c.Row
'            sheet1 de bulunan irs numberların Part No larının aktarımı
            j = irsRow + 2
'            Sheet2 ye tarihleri yazar
            Sheet2.Cells(irsRow - 1, col + 1) = Sheet1.Cells(irsNumberRow, "C")
            'tarihler yazıldı
            For i = partnumberBsCol To partnumberBtCol
                If Sheet1.Cells(irsNumberRow, i) < 0 Then
                    Sheet2.Cells(j, col) = Abs(Sheet1.Cells(irsNumberRow, i))
                Else
                    Sheet2.Cells(j, col) = Sheet1.Cells(irsNumberRow, i)
                End If
                j = j + 1
            Next i
        End If
        col = col + 2
    Loop
Next a

Application.ScreenUpdating = True

End Sub

Harici Link İçin Tıklayınız

Öncelikler teşekkür ederim. Deneme yaptığım için biraz excellerde farklılık oldu. Kusura bakmayın. Bundan sonra excelleri netleştirip sorularda ona göre atarım. Elinize sağlık.

 

[Necdet]

Deneme yapıyorsunuz ama kodlar da sizin eklediğiniz verilere göre yazılıyor.
Dosyanız asıl dosyanızın bire bir aynı olması gerekir ki kodlardan yararlanabilin.
Ben resmen takla attım kodları yazarken. oysa kodlar daha kısa olabilirdi.