• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Bir Sayfadaki Resimler Üzerine Sayı Yazdırma

E

efem67

Katılım
26 Aralık 2011
Mesajlar
164
Excel Vers. ve Dili
Office 2016
Değerli üstadalarım Merhabalar;
Excel dosyasındaki Numaralar sayfasında bulunan ve başlangıç numarası
ve bitiş numarası verilen sayıların sayfa 2 deki 10 adet olan resim bilgisine
Text box içinde sıralı yazdırılması gerekiyor.
Dosya Ekleyemedim. Altın üyeliğim var ama...

Emeğiniz için şimdiden teşekkürler..
 
Değerli üstadalarım Merhabalar;
Excel dosyasındaki Numaralar sayfasında bulunan ve başlangıç numarası
ve bitiş numarası verilen sayıların sayfa 2 deki 10 adet olan resim bilgisine
Text box içinde sıralı yazdırılması gerekiyor.
Dosya Ekleyemedim. Altın üyeliğim var ama...

Emeğiniz için şimdiden teşekkürler..
 

Ekli dosyalar

Bu kodu bir dene

Kod: 
Sub deneme()

Set s1 = Sheets("Numaralar")
Set s2 = Sheets("Sayfa1")

bas = s1.Cells(2, 1).Value
bit = s1.Cells(2, 2).Value

say = bas - 1
Dim Picture As Object

For Each Picture In s2.Shapes
If Picture.Type = 17 And TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "TextBox" Then
s2.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = ""
End If
Next Picture

For Each Picture In s2.Shapes
If Picture.Type = 17 And TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "TextBox" Then
'MsgBox Picture.Type & Chr(10) & TypeName(s2.Shapes(Picture.Name).OLEFormat.Object)
say = say + 1
s2.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = say
If say = bit Then GoTo atla
End If
Next Picture

atla:
MsgBox "işlem tamam"
End Sub
 
Değerli üstadım teşekkürler, SERİ olarak yanına A , B ,C ,D VS de eklemek istediğimde
örn: A- 1 , A-2 gibi bir değişken daha eklemek mi gerekecek...
Saygılarımla;
 
Kod: 
s2.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = say
Yukarıdaki bölüme aşağıdaki gibi ekleme yapabilirsiniz.

Rich (BB code): 
s2.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = "A" & say
 
birinci dosyanız ile ikinci eklediğiniz dosyalarda nesneler farklı olduğu için istenen sonuç alınamıyor
başkaca yazışmalar yapmamak için dosyanızın son halini ve gerekli değişkenleri bildirirseniz birşeyler yapılabilir.
 
Uyarı
Nesnelerin yeri değiştiği zaman kod istenen sonuçları vermez sizin dosyanıza göre hazırlanmış kod esasında nesneleri silip yeniden nesne oluşturmak daha doğru olurdu herhalde

Mevcut dosyanıza göre bu kod çalışyor.

Kod: 
Sub deneme3()

Set s1 = Sheets("Numaralar")
Set s2 = Sheets("Sayfa1")

bas = s1.Cells(2, 1).Value
bit = s1.Cells(2, 2).Value

say = bas - 1
ReDim deg(100)
Dim Picture As Object
sat = 0
For Each Picture In s2.Shapes
sat = sat + 1
deg(sat) = 0
If Picture.Type = 17 And TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "TextBox" Then
s2.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = ""
sat2 = sat2 + 1
deg(sat) = sat2

End If
Next Picture

say3 = 0
For i = 1 To 30
If deg(i) <> 0 Then
say = say + 1
say3 = say3 + 1
s2.Shapes(i).OLEFormat.Object.Characters.Text = say 'deg(i)
s2.Shapes(i + 10).OLEFormat.Object.Characters.Text = s1.Cells(2, 3).Value
If say3 = 10 Then GoTo atla
If say = bit Then GoTo atla
End If
Next i

atla:
MsgBox "işlem tamam"
End Sub
 
Bu kod daha kullanışlı
Kod: 
Sub nesnesil()
Set s2 = Sheets("Sayfa1")
Dim Picture As Object
For Each Picture In s2.Shapes
If Picture.Type = 17 Or Picture.Type = 12 Or Picture.Type = 1 Then
Picture.Delete
End If
Next Picture
End Sub


Sub Ekle_Nesne()

'On Error Resume Next
Set sh = Sheets(ActiveSheet.Name)
Dim Picture As Object
ReDim sutun(4)

sutun(1) = 4
sutun(2) = 5
sutun(3) = 9
sutun(4) = 10

Set s1 = Sheets("Numaralar")
Set s2 = Sheets("Sayfa1")

bas = s1.Cells(2, 1).Value
bit = s1.Cells(2, 2).Value
harf = s1.Cells(2, 3).Value
sat4 = bas - 1
sat5 = bas - 1

For Each Picture In s2.Shapes
If Picture.Type = 17 Or Picture.Type = 12 Or Picture.Type = 1 Then
Picture.Delete
End If
Next Picture

Dim cell As Range
Say = 10
sat1 = 1
sat2 = sat1 + 10

For r = 1 To 5

sut1 = 1
sut2 = sut1 + 4
For j = 1 To 2

Set cell2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2).Address)
s2.Shapes.AddShape(msoShapeRectangle, cell2.Left + 1, cell2.Top + 2, cell2.Width - 3, cell2.Height - 3).Select

Say6 = s2.Shapes.Count
ad1 = s2.Shapes(Say6).Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Fill.Visible = msoTrue
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Fill.Solid
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Fill.ForeColor.RGB = RGB(68, 114, 196)
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Line.Visible = msoTrue
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Line.ForeColor.RGB = RGB(47, 82, 143)
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
s2.Shapes(ad1).OLEFormat.Object.Name = "Res " & Say6

sut1 = sut1 + 5
sut2 = sut1 + 4
sat5 = sat5 + 1
If sat5 = bit Then GoTo atla4

Next j

atla4:

For i = 1 To 4
Set cell = s2.Cells(Say, sutun(i))


s2.Shapes.AddTextbox(msoTextOrientationHorizontal, cell.Left, cell.Top, cell.Width - 6, 21.75).Select
Say6 = s2.Shapes.Count
ad1 = s2.Shapes(Say6).Name
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Fill.Visible = msoTrue
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Fill.Solid
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = 9
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Line.Visible = msoTrue
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Line.ForeColor.SchemeColor = 64
s2.Shapes(ad1).OLEFormat.Object.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

If i Mod 2 = 1 Then
s2.Shapes(ad1).OLEFormat.Object.Characters.Text = harf
Else
sat4 = sat4 + 1
s2.Shapes(ad1).OLEFormat.Object.Characters.Text = sat4
End If

s2.Shapes(ad1).OLEFormat.Object.Name = "Nes " & Say6

If sat4 = bit Then GoTo atla3
Next i

sat1 = sat1 + 11
sat2 = sat1 + 10
Say = Say + 11
Next r

atla3:
Range("A1").Select
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
    

End Sub
 

Ekli dosyalar

Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst