Makro ile listeleme

Mehmet Sait · 29 Nisan 2017

Merhabalar;

Makro yardımı ile belirli sayfadan bilgileri liste halinde getirmek istiyorum.
Açıklama ve örnek dosya ektedir.

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

numan şamil · 29 Nisan 2017

Merhaba
Dener misiniz

Kod:

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: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 S2.Range("G2").Value = S1.Range("O" & i).Value 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, "G").End(xlUp).Row
son2 = S2.Cells(65536, "H").End(xlUp).Row
S2.Cells(son1, "G").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & son1))
S2.Cells(son2, "H").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))
Application.ScreenUpdating = True
MsgBox "İşleminiz bitti", vbInformation, "Numan Şamil"
End Sub

Mehmet Sait · 30 Nisan 2017

Merhaba Numan Şamil bey,

Emeğinize sağlık, teşekkür ederim.

Mehmet Sait · 30 Nisan 2017

Hocam,

Vardiya kısmında küçük harf yazıldığında da listeleme yapabilir mi ? ve Hesaplama yapılan satıra " Toplam " ibaresini ekleme imkanı var mı ?

Teşekkür ederim.

Korhan Ayhan · 30 Nisan 2017

Merhaba,

Teşekkür etmek için bile alıntı özelliğini kullanıyorsunuz.

Lütfen mesajlarınızda gerektiği zaman alıntı yapınız.

Mehmet Sait · 30 Nisan 2017

Merhaba Korhan Ayhan bey,

Öncelikle uyarınız için teşekkür ederim.

Kodları seçmek için "Tüm Kodu Seç" butonuna tıkladığımda ana sayfaya yönlendiriliyorum.
Bilginize,

Teşekkür ederim.

numan şamil · 30 Nisan 2017

Merhaba
Kodları aşağıdaki kodlar ile değiştirip dener misiniz

Kod:

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: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, "G").End(xlUp).Row
son2 = S2.Cells(65536, "H").End(xlUp).Row
son3 = S2.Cells(65536, "C").End(xlUp).Row
S2.Cells(son1, "G").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & son1))
S2.Cells(son2, "H").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))
S2.Cells(son3, "C").Offset(1, 0) = "TOPLAM"
Application.ScreenUpdating = True
MsgBox "İşleminiz bitti", vbInformation, "Numan Şamil"
End Sub

Yada

Kod:

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
    son = S2.Cells(65536, "G").End(xlUp).Row
S2.Range("B" & son & ":F" & son).UnMerge
    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, "G").End(xlUp).Row
son2 = S2.Cells(65536, "H").End(xlUp).Row
son3 = S2.Cells(65536, "B").End(xlUp).Row

S2.Cells(son1, "G").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & son1))
S2.Cells(son2, "H").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))

S2.Range("B" & son3 & ":F" & son3).Offset(1, 0).Merge
S2.Cells(son3, "B").Offset(1, 0) = "TOPLAM"
  
Application.ScreenUpdating = True
MsgBox "İşleminiz bitti", vbInformation, "Numan Şamil"
End Sub

bu şekilde kullanabilirsiniz

Mehmet Sait · 2 Mayıs 2017

Hocam Merhaba,

Tam istediğim gibi olmuş. Emeğinize sağlık, Teşekkür ederim.

Sadece bu kısmı

son1 = S2.Cells(65536, "G").End(xlUp).Row
son2 = S2.Cells(65536, "H").End(xlUp).Row
son3 = S2.Cells(65536, "B").End(xlUp).Row

S2.Cells(son1, "G").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & son1))
S2.Cells(son2, "H").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))

S2.Range("B" & son3 & ":F" & son3).Offset(1, 0).Merge
S2.Cells(son3, "B").Offset(1, 0) = "TOPLAM"

Yazı fontu 12 kalın ve hücrede ortalama yapılabilir mi ?

numan şamil · 2 Mayıs 2017

Merhaba
Kodları aşağıdaki gibi değiştirebilir misiniz?

Kod:

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
    son = S2.Cells(65536, "G").End(xlUp).Row
'S2.Range("B" & son & ":F" & son).UnMerge
S2.Range("B" & son & ":L" & son).Offset(0, 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, "G").End(xlUp).Row
son2 = S2.Cells(65536, "H").End(xlUp).Row
son3 = S2.Cells(65536, "B").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, "G").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & Son1))
S2.Cells(son2, "H").Offset(1, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))

S2.Range("B" & son3 & ":F" & son3).Offset(1, 0).Merge
S2.Cells(son3, "B").Offset(1, 0) = "TOPLAM"
 S2.Range("B" & Son1 & ":H" & Son1).Offset(1, 0).Font.Name = "Arial"
 S2.Range("B" & Son1 & ":H" & Son1).Offset(1, 0).Font.Size = 12
 S2.Range("B" & Son1 & ":H" & Son1).Offset(1, 0).Font.Bold = True
S2.Range("B" & Son1 & ":H" & Son1).Offset(1, 0).HorizontalAlignment = xlCenter
S2.Range("B" & Son1 & ":H" & Son1).Offset(1, 0).VerticalAlignment = xlCenter

Application.ScreenUpdating = True
MsgBox "İşleminiz bitti", vbInformation, "Numan Şamil"
End Sub

numan şamil · 2 Mayıs 2017

9. mesajımdaki kodlar güncellendi.

Mehmet Sait · 2 Mayıs 2017

Teşekkür ederim hocam

numan şamil · 2 Mayıs 2017

iyi çalışmalar

Mehmet Sait · 9 Mayıs 2017

Merhaba Numan bey,

Tablo çizimini ekli resimde ki gibi yapmak için ne yapmam gerek.

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

numan şamil · 9 Mayıs 2017

Merhaba
Önce TOPLAM yazan satırın komplesini DELETE ile silin
Sonra kodlarınızı aşağıdaki kodlar ile değiştirip uygulayın

Kod:

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, "G").End(xlUp).Row
'S2.Range("B" & son & ":F" & son).UnMerge
S2.Range("B" & son & ":L" & son).Offset(0, 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, "G").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, "G").Offset(2, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & Son1))
S2.Cells(son2, "H").Offset(2, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))

S2.Range("C" & son3 & ":F" & son3).Offset(2, 0).Merge
S2.Cells(son3, "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 & ":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 · 10 Mayıs 2017

merhaba Numan Hoca,

Öncelikle yardımlarınız için teşekkür ederim. Verdiğiniz son kodu uyguladığımda örnek dosyada ki gibi oluyor.

Teşekkür ederim.

numan şamil · 10 Mayıs 2017

Merhaba
Gözden kaçırmışım
Ekli dosyada sayfa1 deki butana basıp sonucu bekler misiniz

Kodlar

Kod:

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, "G").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, "G").Offset(2, 0) = WorksheetFunction.Sum(S2.Range("G10:G" & Son1))
S2.Cells(son2, "H").Offset(2, 0) = WorksheetFunction.Sum(S2.Range("H10:H" & son2))

S2.Range("C" & son3 & ":F" & son3).Offset(2, 0).Merge
S2.Cells(son3, "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 & ":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 · 10 Mayıs 2017

Numan hoca,

Tam istediğim gibi olmuş. Ellerinize sağlık.

Teşekkür ederim.

numan şamil · 10 Mayıs 2017

İyi çalışmalar

Mehmet Sait · 17 Mayıs 2017

Merhaba Numan Hoca,

Listeleme de, tablo sayfasında A,B ve C sütunları boş olduğunda listede sıra no vermiyor. Bu kriteri nasıl devre dışı bırakabiliriz.

Teşekkür ederim.

Makro ile listeleme

Mehmet Sait

Ekli dosyalar

numan şamil

Destek Ekibi

Mehmet Sait

Mehmet Sait

Korhan Ayhan

Administrator

Mehmet Sait

numan şamil

Destek Ekibi

Mehmet Sait

numan şamil

Destek Ekibi

numan şamil

Destek Ekibi

Mehmet Sait

numan şamil

Destek Ekibi

Mehmet Sait

Ekli dosyalar

numan şamil

Destek Ekibi

Mehmet Sait

Ekli dosyalar

numan şamil

Destek Ekibi

Ekli dosyalar

Mehmet Sait

numan şamil

Destek Ekibi

Mehmet Sait

Ekli dosyalar