DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Birlestir()
Dim Satir As Long, Adet As Long, SayfaSonSat As Long
Dim Sayfa As Integer, SayiSat As Long
Dim s1 As Worksheet
Set s1 = Sheets("VERİ DEPOSU")
Application.ScreenUpdating = False
s1.Select
Satir = [B65536].End(3).Row + 1
For Sayfa = 1 To Sheets.Count
If Sheets(Sayfa).Name <> "VERİ DEPOSU" Then
SayfaSonSat = Sheets(Sayfa).[B65536].End(3).Row
If SayfaSonSat > 3 Then
Adet = SayfaSonSat - 3
Satir = [B65536].End(3).Row + 1
Sheets(Sayfa).Range("A4:E" & SayfaSonSat).Copy Range("A" & Satir)
Range("F" & Satir & ":F" & Satir + Adet - 1) = Sheets(Sayfa).[B2]
Range("G" & Satir & ":G" & Satir + Adet - 1) = Sheets(Sayfa).[A1]
End If
End If
Next Sayfa
SayiSat = s1.[B65536].End(3).Row
s1.Range("A3:A" & SayiSat).ClearContents
s1.Range("A3") = 1: s1.Range("A" & SayiSat) = SayiSat - 2
s1.Range("A3:A" & SayiSat).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
Application.ScreenUpdating = True
MsgBox "Birleştirme Gerçekleştirildi...", vbInformation, "[URL="http://www.excel.web.tr"]www.excel.web.tr[/URL]"
End Sub
Option Explicit
Sub Birlestir()
Dim VeriSonSat As Long, SayfaSonSat As Long, SayiSat As Long, s1 As Worksheet
Application.ScreenUpdating = False
Set s1 = Sheets("VERİ DEPOSU")
VeriSonSat = s1.[B65536].End(3).Row + 1
SayfaSonSat = ActiveSheet.[B65536].End(3).Row
If ActiveSheet.Name = "VERİ DEPOSU" Then Exit Sub
If [B4] = "" Then Exit Sub
Range("B4:E" & SayfaSonSat).Copy s1.Range("B" & VeriSonSat)
s1.Range("F" & VeriSonSat & ":F" & VeriSonSat + SayfaSonSat - 4) = Range("B2")
s1.Range("G" & VeriSonSat & ":G" & VeriSonSat + SayfaSonSat - 4) = Range("A1")
SayiSat = s1.[B65536].End(3).Row
s1.Range("A3:A" & SayiSat).ClearContents
s1.Range("A3") = 1
s1.Range("A" & SayiSat) = VeriSonSat - 1
s1.Range("A3:A" & SayiSat).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
Application.ScreenUpdating = True
End Sub