Makro Resim Atma

[serkan.sevinc]

Merhaba,
Ekteki dosyada Depoları Süz dediğimde açılan sayfalara resimleri gönderemiyorum. Yardımcı olursanız sevinirim.

 

[serkan.sevinc]

yardımcı olabilir misiniz?

 

[serkan.sevinc]

yardım lütfen

 

[serkan.sevinc]

Yardım edebilecek var mı acaba

 

[serkan.sevinc]

yardım edebilecek misiniz?

 

[Korhan Ayhan]

Merhaba,

Sayfalara Dağıt makronuzu aşağıdaki gibi değiştirip deneyiniz.

Sub sayfalara_dağıt()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("data")
For i = 3 To s1.Range("u65536").End(xlUp).Row Step 7
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, "u").Value)
If s1.Cells(i, "v") = "" Then
sonsatir = s2.Range("A65536").End(xlUp).Row + 1
s2.Cells(sonsatir, "a") = s1.Cells(i, "ı")
s2.Cells(sonsatir, "b") = s1.Cells(i, "d")
s2.Cells(sonsatir, "c") = s1.Cells(i, "e")
s2.Cells(sonsatir, "d") = s1.Cells(i, "h")
s2.Cells(sonsatir, "e") = s1.Cells(i, "u")
s2.Cells(sonsatir, "f") = s1.Cells(i, "l")
s2.Cells(sonsatir, "g") = "" 's1.Cells(i, "l")
s2.Cells(sonsatir, "h") = "" 's1.Cells(i, "m")
s2.Cells(sonsatir, "ı") = "" 's1.Cells(i, "u")
s2.Cells(sonsatir, "j") = "" 's1.Cells(i, "u")
s2.Cells(sonsatir, "k") = "" 's1.Cells(i, "u")
s2.Cells(sonsatir, "l") = "" 's1.Cells(i, "u")

s1.Range("K" & i & ":K" & i + 6).Copy ThisWorkbook.Worksheets(s1.Cells(i, "u").Value).Cells(sonsatir, "m")

s1.Cells(i, "v") = "gitti"
say = say + 1
End If

Next i
Application.ScreenUpdating = True

If say >= 1 Then MsgBox (say & " adet veri sayfalara gönderildi.") & vbCrLf
If say = 0 Then MsgBox (" gönderilecek veri bulunamadı."), vbCritical

End Sub

 

[serkan.sevinc]

çok teşekkür ederim

 

[Ömer]

Merhaba,

Alternatif olsun.

Sub sayfalara_dağıt()

    Application.ScreenUpdating = False
    On Error Resume Next
    
    Set S1 = ThisWorkbook.Worksheets("data")
    
    For i = 3 To S1.Cells(Rows.Count, "U").End(xlUp).Row Step 7
        Set S2 = ThisWorkbook.Worksheets(S1.Cells(i, "u").Value)
        If S1.Cells(i, "V") = "" Then
            sonsatir = S2.Range("A65536").End(xlUp).Row + 1
            S2.Cells(sonsatir, "A") = S1.Cells(i, "I")
            S2.Cells(sonsatir, "B") = S1.Cells(i, "D")
            S2.Cells(sonsatir, "C") = S1.Cells(i, "E")
            S2.Cells(sonsatir, "D") = S1.Cells(i, "H")
            S2.Cells(sonsatir, "E") = S1.Cells(i, "U")
            S2.Cells(sonsatir, "F") = S1.Cells(i, "I")
            S2.Cells(sonsatir, "G") = "" 's1.Cells(i, "l")
            S2.Cells(sonsatir, "H") = "" 's1.Cells(i, "m")
            S2.Cells(sonsatir, "I") = "" 's1.Cells(i, "u")
            S2.Cells(sonsatir, "J") = "" 's1.Cells(i, "u")
            S2.Cells(sonsatir, "K") = "" 's1.Cells(i, "u")
            S2.Cells(sonsatir, "L") = "" 's1.Cells(i, "u")
            
            Sheets("data").Cells(i, "H").Select
            
            Dim shp As Shape, alan As Range
            
            Set alan = Range(Replace(Selection.Address, "H", "K"))
            
            For Each shp In ActiveSheet.Shapes
                If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), _
                        alan) Is Nothing Then
                    shp.Select Replace:=False
                    Selection.Copy
                    S2.Select
                    Cells(sonsatir, "m").Select
                    ActiveSheet.Paste
                    Sheets("data").Select
                    Exit For
                End If
            Next shp
            
            S1.Cells(i, "V") = "gitti"
            say = say + 1
        End If
    
    Next i
    S1.Range("U3").Select
    Application.ScreenUpdating = True
    
    If say >= 1 Then MsgBox (say & " adet veri sayfalara gönderildi.") & vbCrLf
    If say = 0 Then MsgBox (" gönderilecek veri bulunamadı."), vbCritical

End Sub

.

 

[serkan.sevinc]

Teşekkür ederim