Otomatik Tablo Oluşturma

[1Al2Ver]

Merhaba,

Diğer sayfadan, "Rastgelearada" ve "İndis" ile oluşturduğum tabloyu, makro ile oluşturmak istiyorum,

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Dosyam için çözüm arayışım sürmektedir,

Teşekkür ederim.

 

[Ömer]

Merhaba,

Deneyiniz.
Not: İL_PLANLAMA sayfasında 3. satırdaki bölge adları ile BÖLGELER sayfası 1. satırdaki bölge adları aynı olmalıdır. Çünkü kodlar sütun indislerini bu bilgilere bakara buluyor.

Sub tabloya_dagit()
    
    Dim S1 As Worksheet, Wf As WorksheetFunction, sat As Long, son As Long, c As Range, Adr As String
    
    Set S1 = Sheets("BÖLGELER")
    Set Wf = WorksheetFunction
    
    Application.ScreenUpdating = False
    Sheets("İL_PLANLAMA").Select
    Range("D3:I33").ClearContents
    
    sat = Application.Max(Range("A3:A33")) + 2
    
    For i = 4 To 9
        Set c = S1.Rows(1).Find(Cells(2, i), , xlValues, xlWhole)
        If Not c Is Nothing Then
            son = S1.Cells(Rows.Count, c.Column).End(xlUp).Row - 1
            For j = 3 To sat
                Cells(j, i) = Wf.Index(S1.Cells(2, c.Column).Resize(son, 1), Wf.RandBetween(1, son))
            Next j
        End If
    Next i
    
End Sub

 

[1Al2Ver]

Sayın Ömer merhaba,

İlginiz ve çözüm için çok teşekkür ederim,

Bölgelerdeki gruplardan birisinin verileri girilmediğinde, sütunda veri olmadığı için doğal olarak 400 hata uyarısı vermekte, ancak yine de hesaplıyor,

Çok önemli olmamakla beraber bunu aşabilir miyiz ?

Tekrar teşekkür ederim.

 

[Ömer]

Yanlış anlamış olabilirim.

Deneyiniz. İstediğiniz bu değilse daha detaylı açıklar mısınız.

Sub tabloya_dagit()
    
    Dim S1 As Worksheet, Wf As WorksheetFunction, sat As Long, son As Long, c As Range, Adr As String
    
    Set S1 = Sheets("BÖLGELER")
    Set Wf = WorksheetFunction
    
    Application.ScreenUpdating = False
    Sheets("İL_PLANLAMA").Select
    Range("D3:I33").ClearContents
    
    sat = Application.Max(Range("A3:A33")) + 2
    
    For i = 4 To 9
        If Cells(2, i) <> "" Then
            Set c = S1.Rows(1).Find(Cells(2, i), , xlValues, xlWhole)
            If Not c Is Nothing Then
                son = S1.Cells(Rows.Count, c.Column).End(xlUp).Row - 1
                For j = 3 To sat
                    Cells(j, i) = Wf.Index(S1.Cells(2, c.Column).Resize(son, 1), Wf.RandBetween(1, son))
                Next j
            End If
        End If
    Next i
    
End Sub

 

[1Al2Ver]

Sayın Ömer, tekrar merhaba,

Önerdiğiniz 2 nci kod'un işlevselliği için, "İL_PLANLAMA" sayfasında, İlgili Bölge'nin başlığını silerek çözüme ulaştım,

Nezaketiniz ve ilginiz için tekrar teşekkür ederim,

Saygılarımla.

 

[Ömer]

Sanırım istediğiniz buydu?

Sub tabloya_dagit()
    
    Dim S1 As Worksheet, Wf As WorksheetFunction, sat As Long, son As Long, c As Range, Adr As String
    
    Set S1 = Sheets("BÖLGELER")
    Set Wf = WorksheetFunction
    
    Application.ScreenUpdating = False
    Sheets("İL_PLANLAMA").Select
    Range("D3:I33").ClearContents
    
    sat = Application.Max(Range("A3:A33")) + 2
    
    For i = 4 To 9
        If Cells(2, i) <> "" Then
            Set c = S1.Rows(1).Find(Cells(2, i), , xlValues, xlWhole)
            If Not c Is Nothing Then
                son = S1.Cells(Rows.Count, c.Column).End(xlUp).Row - 1
                If son > 0 Then
                    For j = 3 To sat
                        Cells(j, i) = Wf.Index(S1.Cells(2, c.Column).Resize(son, 1), Wf.RandBetween(1, son))
                    Next j
                End If
            End If
        End If
    Next i
    
End Sub

 

[1Al2Ver]

Ömer bey tekrar merhaba,

Evet bu idi, teşekkür ederim,

Gözümden kaçmış olabilir, önemli değil ama estetik olarak güzel durmayan bir küçük sorun da şu ;

"İL_PLANLAMA" sayfası "F1" ay seçildiğinde, "B3:B33" aralığına seçilen ayın günleri formülle alınıyor,

Olabilir ise, tablonun seçilen ayın gün sayısı kadar oluşmasını arzuluyorum.

Örneğin ;

Şubat 28 seçildiğinde tablo 28 günlük,

Mart seçildiğinde 31 günlük,

Nisan seçildiğinde 30 günlük, oluşması

Teşekkür ederim.

 

[Ömer]

Sayfanın kod bölüme kopyalayıp deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim son As Byte
    
    If Intersect(Target, [B1]) Is Nothing Then Exit Sub
    
    son = Day(DateSerial(Year(Target), Month(Target) + 1, 0))
    
    Application.ScreenUpdating = False
    Range("A3:C33").ClearContents
    
    Range("A3") = 1
    Range("B3") = Target
    Range("A3").Resize(son, 1).DataSeries Type:=xlLinear, Step:=1
    Range("B3").Resize(son, 1).DataSeries Type:=xlChronological, Date:=xlDay, Step:=1
    Range("C3").Resize(son, 1) = "=TEXT(B3, ""gggg"")"
    Range("C3").Resize(son, 1) = Range("C3").Resize(son, 1).Value
    
End Sub

 

[1Al2Ver]

Ömer bey merhaba,

Elinize sağlık,

Verdiğim zahmetler için, emekleriniz için, çok teşekkür ederim, sağ olun.

Saygılarımla.