Makro Yardımı

[Mehmet Sait]

Merhabalar,

Bu güzel çalışma için Numan hocaya tekrar teşekkür ediyorum.

Mevcut kodlarda değişim yapmak zorunda kaldım ancak başaramadım. Açıklama ekli dosyada mevcut.

Teşekkür ederim.

 

[askm]

Hata nerde vermekte. Sayfa tanımlamalarından sonra "on error resume next" komutunu ekleyerek deneyin.

 

[Mehmet Sait]

Hocam,

Sipariş ve Sevkiyat sayfasında " B, J, E, F, P, Q, L, N, M, K " sütunları boş olduğunda listelemeyi doğru yapmıyor. Örnek resimler ektedir.

Teşekkür ederim.

 

[askm]

Kodları aşağıdaki şekilde revize edin.

Sub numan()
    Dim S1, S2 As Worksheet, i, x As Long
    Set S1 = Sheets("SİPARİŞ & SEVKİYAT")
    Set S2 = Sheets("Sayfa1")
    Satır = 10
    Application.ScreenUpdating = False
    S2.Range("B10:L5000").Borders.LineStyle = xlNone
    son = S2.Cells(65536, "B").End(xlUp).Row
'S2.Range("B" & son & ":F" & son).UnMerge
S2.Range("B" & son & ":L" & son).Offset(2, 0).Delete
    S2.Range("B10:L" & Rows.Count).ClearContents
    For i = 5 To S1.Cells(Rows.Count, "A").End(xlUp).Row
                    If S2.Range("D2").Value <> "" And S2.Range("G2").Value <> "" Then
                     If S2.Range("D2").Value = S1.Range("I" & i).Value And UCase(Replace(S2.Range("G2").Value, "i", "İ")) = UCase(Replace(S1.Range("O" & i).Value, "i", "İ")) Then
                        S2.Range("C" & Satır).Value = S1.Range("B" & i).Value
                        S2.Range("D" & Satır).Value = S1.Range("J" & i).Value
                        S2.Range("E" & Satır).Value = S1.Range("E" & i).Value
                        S2.Range("F" & Satır).Value = S1.Range("F" & i).Value
                        S2.Range("G" & Satır).Value = S1.Range("P" & i).Value
                        S2.Range("H" & Satır).Value = S1.Range("Q" & i).Value
                        S2.Range("I" & Satır).Value = S1.Range("L" & i).Value
                        S2.Range("J" & Satır).Value = S1.Range("N" & i).Value
                        S2.Range("K" & Satır).Value = S1.Range("M" & i).Value
                        S2.Range("L" & Satır).Value = S1.Range("K" & i).Value
                     Satır = Satır + 1
                     End If
                    End If
                    Next i
For x = 10 To S2.Range("C65536").End(3).Row
If S2.Cells(x, 3).Value = "" Then
S2.Cells(x, 2).Value = ""
Else
s = s + 1
S2.Cells(x, 2).Value = s
End If
Next x
son1 = S2.Cells(65536, "B").End(xlUp).Row
'son2 = S2.Cells(65536, "H").End(xlUp).Row
'son3 = S2.Cells(65536, "C").End(xlUp).Row
S2.Range("B10:L" & son1).Font.Name = "Arial"
S2.Range("B10:L" & son1).Font.Size = 8
S2.Range("B10:L" & son1).Font.Bold = False
S2.Range("B10:L" & son1).HorizontalAlignment = xlCenter
S2.Range("B10:L" & son1).VerticalAlignment = xlCenter
S2.Range("C10:C" & son1).NumberFormat = "h:mm"

S2.Cells(son1 + 2, "G") = WorksheetFunction.Sum(S2.Range("G10:G" & son1))
S2.Cells(son1 + 2, "H") = WorksheetFunction.Sum(S2.Range("H10:H" & son1))

S2.Range("C" & son1 + 2 & ":F" & son1 + 2).Merge
S2.Cells(son1, "C").Offset(2, 0) = "TOPLAM"
 S2.Range("B" & son1 & ":H" & son1).Offset(2, 0).Font.Name = "Arial"
 S2.Range("B" & son1 & ":H" & son1).Offset(2, 0).Font.Size = 12
 S2.Range("B" & son1 & ":H" & son1).Offset(2, 0).Font.Bold = True
S2.Range("B" & son1 & ":H" & son1).Offset(2, 0).HorizontalAlignment = xlCenter
S2.Range("B" & son1 & ":H" & son1).Offset(2, 0).VerticalAlignment = xlCenter
With S2.Range("B10:L" & [B5000].End(3).Row).Borders
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThin
End With
S2.Range("C" & son1 + 2 & ":H" & son1 + 2).Select
'S2.Range("C" & son1 & ":H" & son1).Offset(2, 0).Select
With Selection.Borders
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThin
End With
Application.ScreenUpdating = True
MsgBox "İşleminiz bitti", vbInformation, "Numan Şamil"
End Sub

 

[Mehmet Sait]

Merhabalar,

Adetler kısmı düzenlemesi tam istediğim gibi olmuş.

Ancak Sipariş ve Sevkiyat sayfasında " B sütunu Randevu Saati " boş olduğunda listeleme sayfasında sıra no vermiyor.

Yardımlarınız için teşekkür ederim.