SayfaBirlestirme

[webuyeislemleri]

B kolnunda resimler olan birden fazla personel çalışma sayfalarım var.
3 ayrı excel sayfası.

Bu üç ayrı excel tek sayfaya topladığımda filitre uygulandığında filitre uygulanan veriye göre ya en alt kısma yada ilk satır resminin üzerine diğer hücredeki resimleri topluyor.

bu konuda ne yapıla bilir.

birleştirilen sayfalarda resim varsa filitre sonrası filitre dışında kalan resimler üst üste son satırda toplanıyor.

bu vba kodu sitede bulmuştum, ama sonuç alamadım.

Sub sayfabirlestir()
Dim yol As String, dosya As String
Dim syf As Worksheet, kop As Range, yap As Integer
Dim bas As Range, bit As Range

Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = Dir(yol & "*.xls")
Do
If dosya = ThisWorkbook.Name Then GoTo a:
Workbooks.Open yol & dosya
ThisWorkbook.Activate

For Each syf In Workbooks(dosya).Worksheets
Set bas = Workbooks(dosya).Worksheets(syf.Name).Range("A2")
Set bit = Workbooks(dosya).Worksheets(syf.Name).Range("A1").SpecialCells(xlCellTypeLastCell)

yap = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1
Set kop = Workbooks(dosya).Worksheets(syf.Name).Range(bas, bit)

kop.Copy Range("A" & yap)


Next syf
Workbooks(dosya).Close False
a:
dosya = Dir
Loop Until dosya = ""
Application.ScreenUpdating = True
End Sub

 

[Korhan Ayhan]

Bu şekilde olan dosyanızı foruma eklerseniz kontrol etme şansımız olabilir. Ben şimdi boş bir excel sayfasına resimler ekleyip filtre uygulaması yaptığımda sizin bahsettiğiniz sorunu yaşamadım.

 

[webuyeislemleri]

örnek ekte

örnek ekte,

ilginize tşk.

 

[halit3]

örnek ekte,

ilginize tşk.

Ekli dosyada sayfa1 de resimler geliyor sayfa2 dede A1 hücresinden seçim yapıyorsunuz ve düğmeye tıklıyorsunuz.

 

[webuyeislemleri]

bu şekilde hiç denemedim, sonuç başarılı

sayfa2 sıkıntısız. görünüyor.

TŞK. gerçek veride deneyeceğim.

çok teşekkür.

 

[webuyeislemleri]

Halit bey,
* Bul bulunduğu sayfa da daha efektif nasıl yapıla bilir.

Çünkü personel listem var,
Firma, Bölüm, Kan Grubu gibi birde fazla filitre kullanma durumunda karmaşık hale gelir.
* Bir sorumda sayfa2 açılır listeyi nasıl yaptınız, benim kafa dur.

örnek,
Sayfa birde filitre uygulananlara bul komutu nasıl uygularım, bul sonuçları yine sayfa2 yazacak.

şimdiden tşk.

 

[halit3]

Halit bey,
* Bul bulunduğu sayfa da daha efektif nasıl yapıla bilir.

Çünkü personel listem var,
Firma, Bölüm, Kan Grubu gibi birde fazla filitre kullanma durumunda karmaşık hale gelir.
* Bir sorumda sayfa2 açılır listeyi nasıl yaptınız, benim kafa dur.

örnek,
Sayfa birde filitre uygulananlara bul komutu nasıl uygularım, bul sonuçları yine sayfa2 yazacak.

şimdiden tşk.

Sayfa1 deki koda aşağıdaki kırmızı yeri ekledim süzme yaparak deneyiniz.

kod:

Sub sayfabirlestir()
Application.ScreenUpdating = False
Dim syf As Worksheet
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
say = 2
For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
If Dir(dosya) <> ThisWorkbook.Name Then
Workbooks.Open dosya
yeni_dosya_adı = ActiveWorkbook.Name
For Each syf In Workbooks(Dir(dosya)).Worksheets
Sheets(syf.Name).Select
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
satir = Picture.BottomRightCell.Row
sutün = Picture.BottomRightCell.Column - 1
ThisWorkbook.Sheets(1).Cells(say, 1).Value = Cells(satir, sutün)
ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
Windows(dosya_adı).Activate
Sheets(Sayfa_Adı).Select
ThisWorkbook.Sheets(1).Cells(say, 2).Select
ActiveSheet.Paste
Set Adres = Range(Cells(say, "b"), Cells(say, "b"))
Selection.Top = Adres.Top + 3
Selection.Left = Adres.Left + 3
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
[COLOR=red]Selection.Placement = xlMoveAndSize
[/COLOR]Windows(yeni_dosya_adı).Activate
say = say + 1
End If
Next Picture
Next syf
Workbooks(Dir(dosya)).Close False
End If
Next
dosya = Dir
Application.ScreenUpdating = True
Range("A1").Select
End Sub

 

[webuyeislemleri]

ok.

büyüksün usta, ALLAH razı olsun. Büyük dertten kurtardın.

tam istediğim gibi oldu.
bul makrosuna gerek kalmadan bu şekilde oldu.

Teşekkür.

http://yazilimyeri.com

 

[webuyeislemleri]

halit bey, bu konu hakkında bir fikriniz var mı? (6 nolu mesaj - Aylara göre ekte ki dosyayı nasıl düzenlerim )
http://www.excel.web.tr/f14/tarihlere-gore-tablodaki-verileri-ilgili-aylara-ta-ymak-t112744.html#post685826