DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Belli_Araliktaki_Hucreleri_Aktar()
Dim rng As Range, i As Long
Set rng = Union(Worksheets("Sayfa1").Range("E4:J19").Cells.SpecialCells(xlCellTypeConstants, 23), _
Worksheets("Sayfa1").Range("E4:J19").Cells.SpecialCells(xlCellTypeFormulas, 23))
With rng
For i = 1 To .Areas.Count
.Areas(i).Copy Worksheets("Sayfa2").Range(.Areas(i).Address)
Next
End With
End Sub
Sub Belli_Araliktaki_Hucreleri_Sec()
Dim rng As Range
Set rng = Union(Worksheets("Sayfa1").Range("E4:J19").Cells.SpecialCells(xlCellTypeConstants, 23), _
Worksheets("Sayfa1").Range("E4:J19").Cells.SpecialCells(xlCellTypeFormulas, 23))
rng.Select
End Sub
Sub Calisma_Sonrasi_Alan_Kopyala_v1()
'Varsayımlar:
'1- kopyalanacak alan Sayfa1'de A1 hücresinden başlamaktadır.
'2- Sayfa1'te kopyalanması arzu edilen veriler dışında veri bulunmamaktadır.
Dim syf1 As Worksheet, syf2 As Worksheet
Dim KopyAlan As Range
Dim SonSat As Long, SonSut As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set syf1 = Worksheets("Sayfa1")
Set syf2 = Worksheets("Sayfa2")
With syf1
SonSat = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
SonSut = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Set KopyAlan = .Range(.Cells(1, 1), .Cells(SonSat, SonSut))
End With
KopyAlan.Copy syf2.Range("A1")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
End Sub
Sub Calisma_Sonrasi_Alan_Kopyala_v2()
'Varsayımlar:
'1- kopyalanacak alan Sayfa3'te herhangi bir hücreden başlamaktadır.
'2- Sayfa3'te kopyalanması arzu edilen veriler dışında veri bulunmamaktadır.
Dim syf3 As Worksheet, syf4 As Worksheet
Dim KopyAlan As Range
Dim IlkSat As Long, IlkSut As Long, SonSat As Long, SonSut As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set syf3 = Worksheets("Sayfa3")
Set syf4 = Worksheets("Sayfa4")
With syf3
IlkSat = .Cells.Find("*", , , , xlByRows, xlNext).Row
IlkSut = .Cells.Find("*", , , , xlByColumns, xlNext).Column
SonSat = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
SonSut = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Set KopyAlan = .Range(.Cells(IlkSat, IlkSut), .Cells(SonSat, SonSut))
End With
KopyAlan.Copy syf4.Cells(IlkSat, IlkSut) 'Sayfa3'te olduğu alanın aynısına Sayfa4'te kopyala
'KopyAlan.Copy syf4.Cells(1, 1) 'Sayfa4'te A1'e kopyala
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
End Sub
Günaydınlar,
B3:O39 aralığında
değer olan alanı seç makrosu lazım.
Aralarda boşluklar var ise onlarda seçilecek
(Geometrik olacak kare yada diktörgen gibi)
yardımlarınızı bekliyorum.
3 örnek verdim ya;
bu 3 örnekle gelen verileri
aynı sayfada, sallıyorum T X S M..... sütunlarından
teker teker elde ediyoruz yani üç seferde,
İlk örnek geldi diyelim.
(E4 H12 aralığına)
ilk örneği seçecek. Kopyalayacak
sonra ikincisi gelecek
(E4:G 15 aralığına)
ikinci örneği seçecek. Kopyalayacak
sonra ücüncüsü geldi diyelim
(E4:I16 aralığına)
üçüncüsün seçecek. Kopyalayacak
...
...
Sayın mancubus
1. çalıştırmamda verileri "A1:C7" aralığına yazdı(arada boş hücreler olabiliyor önemli değil onlarda seçilecek)
2. çalıştırmamda verileri "A1:F9" aralığına yazdı(arada boş hücreler olabiliyor önemli değil onlarda seçilecek)
3. çalıştırmamda verileri "A1:E11" aralığına yazdı(arada boş hücreler olabiliyor önemli değil onlarda seçilecek)
4. çalıştırmamda verileri "A1:B10" aralığına yazdı(arada boş hücreler olabiliyor önemli değil onlarda seçilecek)
5. çalıştırmamda verileri "A1:E8" aralığına yazdı(arada boş hücreler olabiliyor önemli değil onlarda seçilecek)
.....................
Bu şekilde devam edip gidecek.
Sayın mancubus
Her seferinde SABİT (B2:H23) aralığını kopyalayacak bir kod istirham etmekteyim.
Dikkat ettiyseniz diğer sayfalarla bi işimiz yok.
Saygılarımla.
Edit: Kodlar modülde