Merhabalar, elimde 5 senelik ayrı excel dosyalarında ve her excel dosyasının içerisinde farklı sayfalarda yakıt tüketimleri var. Sayfa isimleri araç plakalarına göre verilmiş. Benim istediğim bu 5 ayrı excel dosyasında aynı sayfa ismine sahip sayfaları, bir dosyada alt alta birleştirmek. Yeni oluşacak excelde verileri, eski exceldeki gibi sayfalara da bölebilir, tek sayfaya da atabilir fark etmez. Sayfada ne varsa alt alta aynı başlıklar altında atması yeterli düzenlemeyi ben daha sonra manuel yapabilirim. excel dosyalarını ekledim. Yardımlarınızı bekliyorum
'Option Explicit
Dim benim_son_satirim As Long
Dim basliklar_son_sutun As Long
Sub listeleri_birlestir()
On Error Resume Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sutun As Long
Dim kitap As Workbook
Dim sayfa As Worksheet
Dim hucre As Range
Dim son_hucre_adres As String
Dim i As Long
Dim j As Long
Dim ilk_satir As Long
Dim son_satir As Long
Dim son_sutun As Long
Dim basliklar() As String
Dim hesaplama_durumu
Dim r As Range
hesaplama_durumu = Application.Calculation
Application.Calculation = xlCalculationManual
benim_son_satirim = 5
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ThisWorkbook.Activate
liste_sayfasi.Select
basliklar_son_sutun = Range("XFC4").End(xlToLeft).Column
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Burada amacımız, kişi mavi şeride başlık yazarken herhangi bir tanesini boş bırakırsa o boş sütunu silmektir.
For sutun = basliklar_son_sutun To 1 Step -1
If Cells(4, sutun).Value = "" Then
Cells(4, sutun).EntireColumn.Delete
End If
Next
basliklar_son_sutun = Range("XFC4").End(xlToLeft).Column 'Bazı sütunları silmiş olabiliriz. Bu yüzden son sütunun yeniden hesaplanması gerekti.
ReDim basliklar(1 To basliklar_son_sutun)
For i = 1 To basliklar_son_sutun
basliklar(i) = Cells(4, i)
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Each kitap In Workbooks
kitap.Activate
Application.StatusBar = kitap.Name & " / " & sayfa.Name & " - Toplam Dosya Sayısı=" & (Workbooks.Count - 1)
If kitap.Name = ThisWorkbook.Name Then GoTo devam1
For Each sayfa In Worksheets
sayfa.Select
Application.StatusBar = kitap.Name & " / " & sayfa.Name & " - Toplam Dosya Sayısı=" & (Workbooks.Count - 1) ' & " - şu anda "
Call benim_son_satirim_hesapla
son_hucre_adres = ActiveCell.SpecialCells(xlLastCell).Address
For Each hucre In Range("A1:" & son_hucre_adres)
If hucre.Value <> "" Then
ilk_satir = hucre.Row
GoTo devam2
End If
Next hucre
devam2:
son_satir = ActiveCell.SpecialCells(xlLastCell).Row
son_sutun = ActiveCell.SpecialCells(xlLastCell).Column
For i = 1 To son_sutun
For j = 1 To basliklar_son_sutun
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'basliklar(j)
Set r = Cells.Find(What:=basliklar(j), After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If r Is Nothing Then
GoTo dvm1111
Else
ilk_satir = r.Row
ilk_sutun = r.Column
'If Cells(ilk_satir, ilk_sutun).Value = basliklar(j) Then
Range(Cells(ilk_satir + 1, ilk_sutun).Address & ":" & Cells(son_satir, ilk_sutun).Address).Copy
ThisWorkbook.Activate
liste_sayfasi.Select
Cells(benim_son_satirim, j).PasteSpecial xlPasteValues
Cells(benim_son_satirim, j).PasteSpecial xlPasteFormats
kitap.Activate
GoTo dvm1111
'End If
End If
GoTo dvm1111
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Cells(ilk_satir, i).Value = basliklar(j) Then
Range(Cells(ilk_satir + 1, i).Address & ":" & Cells(son_satir, i).Address).Copy
ThisWorkbook.Activate
liste_sayfasi.Select
Cells(benim_son_satirim, j).PasteSpecial xlPasteValues
Cells(benim_son_satirim, j).PasteSpecial xlPasteFormats
kitap.Activate
GoTo devam3
End If
dvm1111:
Next j
devam3:
Next i
Next sayfa
devam1:
Next kitap
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ThisWorkbook.Activate
liste_sayfasi.Select
Application.StatusBar = ""
MsgBox "İşlem tamamlandı!"
Application.CutCopyMode = False
Range("A1").Select
Cells.EntireColumn.AutoFit
Application.Calculation = hesaplama_durumu
End Sub
Sub benim_son_satirim_hesapla()
On Error Resume Next
Dim i As Long
Dim son_satir As Long
Dim kitap As Workbook
son_satir = 4
Set kitap = ActiveWorkbook
ThisWorkbook.Activate
liste_sayfasi.Select
For i = 1 To basliklar_son_sutun
If Cells(1000000, i).End(xlUp).Row > son_satir Then
son_satir = Cells(1000000, i).End(xlUp).Row
End If
Next i
benim_son_satirim = son_satir + 1
kitap.Activate
End Sub
Sub temizle()
On Error Resume Next
Dim son_hucre_adres As String
ThisWorkbook.Activate
liste_sayfasi.Select
son_hucre_adres = ActiveCell.SpecialCells(xlLastCell).Address
Range("A5:" & son_hucre_adres).Clear
Range("A5").Select
End Sub
Sub sadasdasd()
Dim r As Range
Set r = Cells.Find(What:="eeeeeeee", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If r Is Nothing Then
'handle error
Else
'fill in your code
End If
End Sub
bu kodlar işinizi görecektir 4. satıra almanız gereken başlıklar örnek olarak km yol araç yazarsanız açık olan kitabı tek bir sayfada birleştirir
