ayrı sayfalarda yazılanları tek sayfaya otamatik
aktara bilecegim bir folmül varmı
aktara bilecegim bir folmül varmı
Ekli dosyalar
-
4.9 KB Görüntüleme: 9
Son düzenleme:
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Bence bu işlem makro ile daha doğru olur.ayrı sayfalarda yazılanları tek sayfaya otamatik
aktara bilecegim bir folmül varmı
Örnek dosya yollarsanız yaparım.makro bilmedigim için folmül dedim ama makro,da olur
Sub sayfa_aktar()
Dim sh As Worksheet, sat As Long, sat2 As Long
Application.ScreenUpdating = False
Sheets("ÖZET TABLO").Select
Range("A5:H65536").ClearContents
For Each sh In Worksheets
If sh.Name <> "ÖZET TABLO" Then
sat2 = sh.Cells(65536, "B").End(xlUp).Row
sat = Cells(65536, "B").End(xlUp).Row + 1
sh.Range("A3:G" & sat).Copy
Range("A" & sat).PasteSpecial xlPasteValues
End If
Next
Range("A5:H65536").Sort Range("B2")
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
Rica ederim.Allah sen razı olsun hocam nekadar hayra girdin anlatamam beni sıkıntıdan kurtardın
Sayın Evren BeyDosyanız ektedir.
Kod:Sub sayfa_aktar() Dim sh As Worksheet, sat As Long, sat2 As Long Application.ScreenUpdating = False Sheets("ÖZET TABLO").Select Range("A5:H65536").ClearContents For Each sh In Worksheets If sh.Name <> "ÖZET TABLO" Then sat2 = sh.Cells(65536, "B").End(xlUp).Row sat = Cells(65536, "B").End(xlUp).Row + 1 sh.Range("A3:G" & sat).Copy Range("A" & sat).PasteSpecial xlPasteValues End If Next Range("A5:H65536").Sort Range("B2") Range("A1").Select Application.ScreenUpdating = True MsgBox "Aktarım tamamlandı" & vbLf & _ "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N" End Sub