Koşullu olarak bir tabloyu parçalara bölmek

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Koşullu olarak bir tabloyu parçalara bölmek

İleti#1)  ejderha2k » 15 Eyl 2020 12:09

Herkese iyi günler. Ek de göreceğiniz tabloda ürünlerin eklediğim bir kısım var "ithalat" sayfasında no yazan kısımlardaki rakamlara basınca ürün seçme formu karşımıza çıkıyor ve ürünlerimizi kasa numaralı vs. bilgilerle ekliyoruz benim uğraşıp ta yapamadığım konu şudur oraya eklediğim ürünlerin kasa numaraları koşul olarak alınarak ikinci bir sayfaya parça parça tablo olarak aktarılması ve formatın korunması yani her tablo altında toplam ağırlık gözükmesi.

Konu hakkında fikir verebilecek yada çözüm konusunda örnek dosya göndermeniz mümkün olursa çok sevinirim .
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
The Hunter is Nothing Without the Hunt
Kullanıcı avatarı
ejderha2k
 
Kayıt: 05 Ağu 2020 16:07
Meslek: emekli
Yaş: 42
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#2)  Miraç CAN » 16 Eyl 2020 13:19

Bunu tam olarak anlayamadım, özellikle "parça parça" kısmını:
eklediğim ürünlerin kasa numaraları koşul olarak alınarak ikinci bir sayfaya parça parça tablo olarak aktarılması


Ve tablonuzu örnek şablon olarak ekler misiniz?
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 699
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#3)  ejderha2k » 16 Eyl 2020 14:10

Örnek şablonu excel de sonuç sayfasına ekledim , ilgi ve alakanız için teşekkür ederim
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
The Hunter is Nothing Without the Hunt
Kullanıcı avatarı
ejderha2k
 
Kayıt: 05 Ağu 2020 16:07
Meslek: emekli
Yaş: 42
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#4)  Miraç CAN » 19 Eyl 2020 10:35

Bazı kodlarınıza revizyon ve eklemeler yaparak düzenledim, tablo halinde listeleme için yeni bir yordam hazırladım.
Özetle; Dolu satırlardan seçim yaptığınızda form güncelle modunda açılıyor, ilk boş satırı seçtiğinizde ekleme modunda.
Bu şekilde daha dinamik ve verimli olacağını düşünerek tasarladım, arzu ederseniz her defasında boş olarak gelebilir de.

Form denetiminde yapılan her değişiklik "Sonuç" isimli sayfaya verdiğiniz şablon formatında listeleniyor.
Değiştirmeniz gerekenler; UserForm_Initialize ComboBox2_Change CommandButton3_Click
Yeni eklemeniz gereken; SonucList

...:::| Bunları değiştirin |:::...

Kod: Tümünü seç
Private Sub UserForm_Initialize()
    Me.Caption = "Yeni Ekle (" & ActiveCell.Row - 1 & ")"
    Me.TextBox4.Locked = True
    For i = 2 To son_satir
        If WorksheetFunction.CountIf(Sayfa1.Range("A2:A" & i), Sayfa1.Cells(i, 1).Value) = 1 Then
            ComboBox1.AddItem Sayfa1.Cells(i, 1).Value
        End If
    Next i
    For Y = 1 To 10 Step 1
        Y = Round(Y, 1)
        ComboBox3.AddItem Y
    Next Y
    If Not IsEmpty(ActiveCell(1, 2)) Then
        Me.Caption = "Güncelle (" & ActiveCell.Row - 1 & " - " & ActiveCell(1, 2) & ")"
        Me.CommandButton3.Caption = "Güncelle"
        Me.ComboBox1.Value = ActiveCell(1, 2).Value
        Me.ComboBox2.Value = ActiveCell(1, 3).Value
        Me.TextBox3.Value = ActiveCell(1, 5).Value
        Me.ComboBox3.Value = ActiveCell(1, 6).Value
    End If
End Sub

Kod: Tümünü seç
Private Sub ComboBox2_Change()
    If Not ActiveControl Is Nothing Then If ActiveControl.Name Like "ComboBox1" Then Exit Sub
    Dim Bul As Range
    Set Bul = Sheets("Ürünler").Columns(2).Find(what:=ComboBox2.Text, LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    If IsEmpty(Bul.Offset(0, 1).Value) Then
        Me.TextBox4 = Empty
        If MsgBox("Birim Ağırlık Bulunamadı" & vbNewLine & "Manuel eklemek istiyor musunuz..?", _
            vbCritical + vbDefaultButton2 + vbYesNo, "Dikkat..!") = vbYes Then Me.TextBox4.Locked = False: Me.TextBox4.SetFocus
    Else
        TextBox4.Text = Bul.Offset(0, 1).Value
        Me.TextBox4.Locked = True
    End If
End Sub

Kod: Tümünü seç
Private Sub CommandButton3_Click()
Dim Mx&, ScUp As Boolean, Calc&
If ComboBox1 <> "" And ComboBox2 <> "" And ComboBox3 <> "" And TextBox3 <> "" And TextBox4 <> "" Then
    ScUp = Application.ScreenUpdating: Application.ScreenUpdating = False
    Calc = Application.Calculation: Application.Calculation = xlCalculationManual
    Mx = Application.Max([A:A])
    With ActiveCell
        If ActiveCell.Row > Mx + 1 Then
            Cells(Mx + 2, 7).Cut Cells(Mx + 3, 7)
            Cells(Mx + 2, 8).Cut Cells(Mx + 3, 8)
            Cells(Mx + 3, 8).Formula = "=SUM(H2:H" & Mx + 2 & ")"
            .Offset(, 7).Interior.ThemeColor = xlThemeColorDark2
            .Offset(, 6).Resize(, 2).NumberFormat = "General ""kg"""
            .Offset(, 3).Resize(, 5).HorizontalAlignment = xlCenter
            .Offset(, 3).Resize(, 5).VerticalAlignment = xlCenter
            .Offset(, 6).HorizontalAlignment = xlLeft
            .Offset(, 6).IndentLevel = 1
            With .Resize(, 8)
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).Weight = xlThin
                .Font.ThemeColor = xlThemeColorLight1
                .Font.TintAndShade = 0.249977111117893
            End With
        End If
        .Value = .Row - 1
        .Offset(, 1) = ComboBox1
        .Offset(, 2) = ComboBox2
        .Offset(, 3) = "Adet"
        .Offset(, 4) = CDbl(TextBox3)
        .Offset(, 5) = CDbl(ComboBox3)
        .Offset(, 6) = CDbl(TextBox4)
        .Offset(, 7) = CDbl(TextBox3) * CDbl(TextBox4)
    End With
    Me.Hide
    SonucList
    Application.Calculation = Calc
    Application.ScreenUpdating = ScUp
Else
    MsgBox "Eksik!"
End If
Unload Me
End Sub

...:::| Bunu da ekleyin |:::...

Kod: Tümünü seç
Private Sub SonucList()
Dim TempArr() As Variant, Kasa&, Cl&, Rw&
Dim ArrEmpty(1 To 10) As Long, TopKg#
ReDim Preserve TempArr(1 To 10, 2 To 8, 0 To 0)
For Rw = 2 To Cells(Rows.Count, 1).End(3).Row
    For Cl = 2 To 8
        If UBound(TempArr, 3) < ArrEmpty(Cells(Rw, 6)) Then _
            ReDim Preserve TempArr(1 To 10, 2 To 8, 0 To ArrEmpty(Cells(Rw, 6)))
        TempArr(Cells(Rw, 6), Cl, ArrEmpty(Cells(Rw, 6))) = Cells(Rw, Cl)
    Next Cl
    ArrEmpty(Cells(Rw, 6)) = ArrEmpty(Cells(Rw, 6)) + 1
Next Rw
With Sheets("Sonuç")
    With .UsedRange
        .ClearContents
        .NumberFormat = "General"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .IndentLevel = -1
        .Borders(xlInsideHorizontal).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Interior.Color = xlNone
        .Font.Bold = False
        .Font.ColorIndex = xlAutomatic
    End With
    For Kasa = 1 To 10
        If IsEmpty(TempArr(Kasa, 2, 0)) Then GoTo Up
        Range("A1:H1").Copy .Cells(Rows.Count, 7).End(3)(IIf(Kasa = 1, 1, 3), -5)
        .Cells(Rows.Count, 1).End(3).Resize(, 8).Borders(xlEdgeBottom).LineStyle = xlContinuous
        For Rw = 0 To UBound(TempArr, 3)
            If IsEmpty(TempArr(Kasa, 2, Rw)) Then Exit For
            .Cells(Rows.Count, 7).End(3)(2, -5) = Rw + 1
            For Cl = 2 To 8
                .Cells(Rows.Count, 1).End(3)(1, Cl) = TempArr(Kasa, Cl, Rw)
            Next Cl
            With .Cells(Rows.Count, 1).End(3)(1, 1)
                .Offset(, 7).Interior.ThemeColor = xlThemeColorDark2
                .Offset(, 6).Resize(, 2).NumberFormat = "General ""kg"""
                .Offset(, 3).Resize(, 5).HorizontalAlignment = xlCenter
                .Offset(, 3).Resize(, 5).VerticalAlignment = xlCenter
                .Offset(, 6).HorizontalAlignment = xlLeft
                .Offset(, 6).IndentLevel = 1
                With .Resize(, 8)
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Font.ThemeColor = xlThemeColorLight1
                    .Font.TintAndShade = 0.249977111117893
                End With
            End With
            TopKg = TopKg + TempArr(Kasa, 8, Rw)
        Next Rw
        Cells(Rows.Count, 7).End(3).Resize(, 2).Copy .Cells(Rows.Count, 7).End(3)(2, 1)
        .Cells(Rows.Count, 7).End(3)(1, 2) = TopKg: TopKg = 0
Up: Next Kasa
End With
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 699
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#5)  ejderha2k » 20 Eyl 2020 18:36

Miraç bey ilgi alakanıza çok teşekkür ederim gerçekten olayı çok farklı bir boyuta çekmişsiniz çok çok iyi olmuş.

Ufak bir problem yaşadım yalnız, sorunum şu şekilde ithalat sayfası ful doluyken sorun yok ama boş sayfaya ekleme yapınca eklediğim resimdeki hatayı veriyor.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
The Hunter is Nothing Without the Hunt
Kullanıcı avatarı
ejderha2k
 
Kayıt: 05 Ağu 2020 16:07
Meslek: emekli
Yaş: 42
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#6)  Miraç CAN » 21 Eyl 2020 12:58

Arada boş satırlar olabileceğini belirtmemiştiniz. Bu sebepten hata alıyoruz. Düzeltmeyi yaptım, hatta gözden kaçan ufak tefek detaylarda varmış, onları da giderdim, biraz daha dinamik hale geldi.
Mesela; kasa sayısını arttırdığınızda da hata vermeyecek.
Öngörebildiğim hata denetimlerini de ekledim. TabIndex ayarlandı, artık mouse kullanmadan da (Tab/ENTER/Space/yön tuşları) rahatça işlem yapabileceksiniz.
Ekteki UF dosyasını yüklemeniz (import) yeterli.

Ve önceki cevapta İthalat sayfa kodlarınızı eklemeyi de unutmuşum, güncelleyin:
Kod: Tümünü seç
Public WsChangeCancel As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    If WsChangeCancel Then Exit Sub
    If Intersect(Range("A2:H" & Cells(Rows.Count, 1).End(3).Row), Target) Is Nothing Then Exit Sub
    If Cells(Rows.Count, 1).End(3)(2, 8).Value <> Application.Sum(Range("H2:H" & Cells(Rows.Count, 1).End(3).Row)) Then
        WsChangeCancel = True
        Cells(Rows.Count, 1).End(3)(2, 8) = Application.Sum(Range("H2:H" & Cells(Rows.Count, 1).End(3).Row))
        WsChangeCancel = False
        UserForm1.SonucList
        Unload UserForm1
    End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Range("A2:A" & Cells(Rows.Count, 1).End(3).Row + 1), Target) Is Nothing And Target.Count = 1 Then
      UserForm1.Left = Target.Left + 75
      UserForm1.Top = Target.Top + 150 - Cells(ActiveWindow.ScrollRow, 1).Top
      UserForm1.Show
    End If
End Sub

Bu sayede formata uygun veri girişi yapılmasını sağlarız. Sadece "Toplam Ağırlık" satırına kadar form görüntülenir.
Ayrıca, kullanmadığınız satırları tamamen, satır sil ile de silebilirsiniz.
Yeni ekle form modu görüntülendiğinde sıralı bir şekilde ekleyerek ve devam eder.
İthalat sayfasının minimum boş hali resimdeki gibi kalması format ve yordam için yeterlidir.

Adsız.png

(üst başlık + en az 1 veya daha fazla boş/dolu satır + alt toplam satırı)
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 699
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#7)  Miraç CAN » 21 Eyl 2020 13:05

Yine eski halini eklemişim [uzgun]
Lütfen sadece bunu değiştirin Worksheet_Change diğer üst ve alt kodlar kalsın:
Kod: Tümünü seç
Private Sub Worksheet_Change(ByVal Target As Range)
    If WsChangeCancel Then Exit Sub
    If Intersect(Range("A2:H" & Cells(Rows.Count, 1).End(3).Row), Target) Is Nothing Then Exit Sub
    If Cells(Rows.Count, 1).End(3)(IIf(Cells(Rows.Count, 1).End(3).Row = 1, 3, 2), 8).Value <> _
        Application.Sum(Range("H2:H" & Cells(Rows.Count, 1).End(3).Row)) Then
        WsChangeCancel = True
        Cells(Rows.Count, 1).End(3)(IIf(Cells(Rows.Count, 1).End(3).Row = 1, 3, 2), 8) _
            = Application.Sum(Range("H2:H" & Cells(Rows.Count, 1).End(3).Row))
        WsChangeCancel = False
        UserForm1.SonucList
        Unload UserForm1
    End If
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 699
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Koşullu olarak bir tabloyu parçalara bölmek

İleti#8)  ejderha2k » 21 Eyl 2020 13:24

Valla Miraç bey ne desem az elinize emeğinize sağlık benim yapmak istediğimden çok daha iyi bir hale gelmiş çalışma çok teşekkür ediyorum.
The Hunter is Nothing Without the Hunt
Kullanıcı avatarı
ejderha2k
 
Kayıt: 05 Ağu 2020 16:07
Meslek: emekli
Yaş: 42
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Yandex[Bot] ve 2 misafir

Bumerang - Yazarkafe