A ile başlayan sayfalardaki belirli aralıktaki verileri alt alta data sayfasına eklenmesi

[nazifdural]

Merhabalar,
A(1) den A(50) ye kadar giden sayfalardaki (yükleme alanına almadığı için A(1) - A(2) - A(3) sayfalarını ekledim. diğer sayfaları çıkardım. bu örnekte gözükmüyor.)
aşağıdaki hücre aralıklarını data sayfasına alt alta kopyalamak istiyorum.
(B225 - AP244) - (B251 - AP270) - (B277 - AP296) - (B303 - AP322) - (B329 - AP348) - (B355 - AP374) - (B381 - AP400) - (B407 - AP426) - (B433 - AP452) - (B459 - AP478) - (B485 - AP504) - (B511 - AP530)

Bu şekilde yapılabilirse, data sayfasını pivot tablo veri alanı olarak kullanabileceğim.

Yardımlarınızı bekliyorum.

 

[bmutlu966]

Deneyin.

Sub aktar()

Dim sf As Worksheet

Set d = Sheets("DATA")

d.Range("A6:AP65000").ClearContents
Application.ScreenUpdating = False

For Each sf In Worksheets
If sf.Name <> "ANA SAYFA" And sf.Name <> "ODA" And sf.Name <> "PAZAR" And sf.Name <> "ACENTE" And sf.Name <> "DATA" Then
  
    son = d.[A65536].End(3).Row
    sf.Range("B225:AP530").Copy
    d.Range("A" & son + 1).PasteSpecial xlValues

End If
Next

son = d.[A65536].End(3).Row
For t = son To 6 Step -1
    If d.Cells(t, "A") = "" Or d.Cells(t, "A") = "Ay" Then
        Rows(t).Delete
    End If
Next
Application.ScreenUpdating = True

MsgBox "Tum sayfalar aktarildi."

End Sub

 

[nazifdural]

Üstadım ellerine sağlık. Birde A sayfalarındaki E sütununda(Room Type) boş olan hücreleri getirme diyebilirmiyiz.

 

[bmutlu966]

Üstadım ellerine sağlık. Birde A sayfalarındaki E sütununda(Room Type) boş olan hücreleri getirme diyebilirmiyiz.

Kodu aşağıdaki şekilde değiştirin.

Sub aktar()

Dim sayfa, sf As Worksheet

Set d = Sheets("DATA")

On Error Resume Next

d.Range("A6:AP65000").ClearContents
Application.ScreenUpdating = False

For Each sf In Worksheets
If sf.Name <> "ANA SAYFA" And sf.Name <> "ODA" And sf.Name <> "PAZAR" And sf.Name <> "ACENTE" And sf.Name <> "DATA" Then
    
    son = d.[A65536].End(3).Row
    sf.Range("B225:AP530").Copy
    d.Range("A" & son + 1).PasteSpecial xlValues

End If
Next

son = d.[A65536].End(3).Row
For t = son To 6 Step -1
    If d.Cells(t, "A") = "" Or d.Cells(t, "A") = "Ay" Then
        Rows(t).Delete
    End If
Next

son = d.[A65536].End(3).Row
For t = son To 6 Step -1
    If d.Cells(t, "D") = "" Then
        Rows(t).Delete
    End If
Next

Application.ScreenUpdating = True

MsgBox "Tum sayfalar aktarildi."

End Sub

 

[Ömer]

Merhaba,

Alternatif.

Sub test()
        
    Dim syf As Worksheet, j As Integer, ay As Integer, c As Range, sat As Long, oda As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("DATA").Select
    Range("A3:AO" & Rows.Count) = ""
    
    oda = Sheets("ODA").Cells(22, "C").End(xlUp).Row - 2
    If oda < 1 Then Exit Sub
        
    sat = 3: ay = 225
    For Each syf In ActiveWorkbook.Worksheets
        With syf
            If .Name Like "A(*)" Then
                For j = ay To 530 Step 26
                    .Cells(j, "B").Resize(oda, 42).Copy
                    Cells(sat, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
                    sat = sat + oda
                Next j
            End If
        End With
    Next syf
    Application.CutCopyMode = False
    
    MsgBox "İşlem bitti"
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
End Sub

 

[nazifdural]

Her iki cevap içinde çok teşekkürler. Ellerinize sağlık.

 

[nazifdural]

Merhaba,

Alternatif.

Sub test()
      
    Dim syf As Worksheet, j As Integer, ay As Integer, c As Range, sat As Long, oda As Integer
  
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("DATA").Select
    Range("A3:AO" & Rows.Count) = ""
  
    oda = Sheets("ODA").Cells(22, "C").End(xlUp).Row - 2
    If oda < 1 Then Exit Sub
      
    sat = 3: ay = 225
    For Each syf In ActiveWorkbook.Worksheets
        With syf
            If .Name Like "A(*)" Then
                For j = ay To 530 Step 26
                    .Cells(j, "B").Resize(oda, 42).Copy
                    Cells(sat, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
                    sat = sat + oda
                Next j
            End If
        End With
    Next syf
    Application.CutCopyMode = False
  
    MsgBox "İşlem bitti"
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
  
End Sub

Üstadım A sayfalarındaki Room (AF Sütununda) sıfır olan satırları getirme olarak nasıl düzenleyebiliriz.

 

[Ömer]

Merhaba,

Detaylı deneme yapmadım. Deneyiniz.

Sub test1()
        
    Dim syf As Worksheet, j As Integer, ay As Integer, c As Range
    Dim sat As Long, oda As Integer, k As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("DATA").Select
    Range("A3:AO" & Rows.Count) = ""
    
    oda = Sheets("ODA").Cells(22, "C").End(xlUp).Row - 2
    If oda < 1 Then Exit Sub
        
    sat = 3: ay = 225
    For Each syf In ActiveWorkbook.Worksheets
        With syf
            If .Name Like "A(*)" Then
                For j = ay To 530 Step 26
                    For k = j To j + 20 - 1
                        If .Cells(k, "AF") <> 0 Then
                            .Cells(k, "B").Resize(, 42).Copy
                            Cells(sat, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
                            sat = sat + 1
                        End If
                    Next k
                Next j
            End If
        End With
    Next syf
    Application.CutCopyMode = False
    
    MsgBox "İşlem bitti"
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
End Sub

 

[nazifdural]

Hocam A sayfalarındaki B - C - D - E sütunlarını siliyor ve Data sayfasına da bu şekilde aktarıyor.

 

[Ömer]

Şimdi denedim. Verileri getiriyor.
Bu şekilde hatalı sonuçların geldiği örnek dosya ekler misiniz.

 

[nazifdural]

Hocam örnek dosya ekte. bu çalışmaya başladıktan sonra bazı değişiklikler yaptım. konuda karışıklık olmasın diye de eski örnekten gittim. kodları şu andaki dosyaya çevirdim. Datada Ocak ayında dolu kayıt sayısı 15. 15 satır veri getirmesi gerekirken, bir şekilde 15 satır x 15 kopya =225 satır getiriyor.
Her ay için aynısını yapıyor, Kodlama ile ilgili bilgim yok fakat acaba bu satırdan mı kaynaklanıyor. For k = j To j + 20 - 1

 

[Ömer]

Aşağıdaki kodları son eklediğiniz örnek dosyanızda değiştirmeden kullanarak deneyiniz. Ben detaylı deneme yapmadım, hatalı aktarım varsa bu dosya ve kodlar üzerinden açıklarsanız sevinirim.
Not: AC sütunu sıfırdan büyük mü diye kontrol ediyor. Bu kısım hatalıysa kendinize göre değiştirirsiniz.

Sub test()
    
    Dim syf As Worksheet, j As Long, ay As Integer, c As Range
    Dim sat As Long, oda As Integer, son_s As Long, k As Long, t As Byte

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("BUTCEDATA2023").Select
    Range("A2:AR" & Rows.Count).ClearContents

    oda = Sheets("ANA SAYFA").Cells(37, "D").End(xlUp).Row - 17
    If oda < 1 Then Exit Sub
    
    sat = 2: ay = 71
    For Each syf In ActiveWorkbook.Worksheets
        With syf
            If .Name Like "A(*)" Then
                son_s = .Cells(Rows.Count, "F").End(xlUp).Row
                For j = ay To son_s Step 26
                    For k = j To j + oda - 1
                        If .Cells(k, "AC") <> 0 Then
                            For t = 1 To 44
                                Cells(sat, t) = .Cells(k, t + 1)
                            Next t
                            sat = sat + 1
                        End If
                    Next k
                Next j
            End If
        End With
    Next syf
    'Application.CutCopyMode = False

    MsgBox "İşlem bitti"
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True

End Sub

 

[nazifdural]

Hocam çok çok çok teşekkürler. Ellerinize sağlık. Allah sizlere sağlık sıhhat ve mutluluklar versin.

 

[Ömer]

Rica ederim. İyi dilekleriniz için teşekkür ederim. Bende size sıhhat ve mutluluk dilerim.
Yine sorun olursa yardımcı olmaya çalışırım.