-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
En Fazla Ürün Türü Seçtirme
- Konbuyu başlatan DMR 7
- Başlangıç tarihi
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,392
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Boşta kalan ürünler aşağıdaki ürünler;
Bunlar hangi bayilere hangi kurala göre dağıtılacak?
Bunlar hangi bayilere hangi kurala göre dağıtılacak?
- Katılım
- 14 Eylül 2017
- Mesajlar
- 129
- Excel Vers. ve Dili
- 2016 / Tr
Boşta kalan ürünler aşağıdaki ürünler;
Bunlar hangi bayilere hangi kurala göre dağıtılacak?
Ürün bazinda bir pahalılık sıralaması olacak hocam. Atiyorum silgi1 en pahali bayii1 de daha sonra bayii 10 da en pahali. Artik kac yerde satılıyor ise.
Bosta kalanlari yerleştirirken, bu pahalilik sırasına bakicaz. Bayii 1 de 5 ürün yerleşmisse gidip bayii 10a atacak. Bayii 10 da doluysa bi sonraki pahali bayiye seklinde. Hic bi bayiye yerlesmiyorsa kalacak öyle.
Tüm cesitler yerlestikten sonra , her bayiyi 5 ürün olacak sekilde kalanlari o bayideki en pahali ürünler ile doldurcaz
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,392
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Aşağıdaki kodu deneyiniz.
Kod:
Option Explicit
Sub BAYİ_ÜRÜN_LİSTESİ_HAZIRLA()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim Ürün_Sayısı As Integer, X As Long, Bul As Range, Adres As String
Dim Son As Long, Satır As Long, Say As Long, Bayi As Variant, Y As Integer
Set S1 = Sheets("Tüm Listeler")
Set S2 = Sheets("Oluşacak Liste")
Set S3 = Sheets("Sıralı Liste")
Ürün_Sayısı = Application.InputBox("Lütfen bayii başına kaç adet ürün listelemek istediğinizi giriniz.", "ÜRÜN ADEDİ BELİRLEME", 5)
If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Cells.Clear
S3.Cells.Clear
S2.Range("A1") = "Sıra No"
S2.Range("A1:A2").Merge
S2.Range("A3") = 1
S2.Range("A3").AutoFill Destination:=S2.Range("A3:A" & Ürün_Sayısı + 2), Type:=xlFillSeries
S2.Cells.VerticalAlignment = xlCenter
With S2.Range("A1:A" & Ürün_Sayısı + 2)
.Font.Bold = True
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 4
End With
With S3.Range("A1:F1")
.Value = Array("BAYİİ NO", "TÜR", "FİYAT", "SIKLIK", "KONTROL", "BAYİİ SIRALAMASI")
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
For X = 2 To S1.Cells(1, S1.Columns.Count).End(1).Column Step 2
If S1.Cells(3, X) <> "" Then
S1.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Copy S2.Cells(1, X)
S2.Cells(3, X).Resize(Ürün_Sayısı, 2).ClearContents
S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
Son = S1.Cells(S1.Rows.Count, X).End(3).Row - 2
Satır = S3.Cells(S3.Rows.Count, 1).End(3).Row + 1
S1.Cells(3, X).Resize(Son, 2).Copy S3.Cells(Satır, 2)
S3.Range("A" & Satır & ":A" & Satır + Son - 1) = S1.Cells(1, X)
End If
Next
Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
With S3.Range("D2:D" & Son)
.Formula = "=COUNTIF(B:B,B2)"
.Value = .Value
End With
With S3.Range("A1:D" & Son)
.Sort S3.Range("B1"), xlAscending, S3.Range("C1"), , xlDescending, , , xlYes
End With
For X = 2 To Son
Set Bul = S3.Range("B:B").Find(S3.Cells(X, 2), , , xlWhole)
If Not Bul Is Nothing Then
Say = WorksheetFunction.CountIf(S3.Range("B:B"), S3.Cells(X, 2))
If Say = 1 Then
S3.Cells(X, 6) = S3.Cells(X, 1)
Else
With S3.Range("F" & X & ":F" & Bul.Row + Say - 1)
.Value = Join(Application.Transpose(S3.Range("A" & X & ":A" & Bul.Row + Say - 1).Value), ",")
End With
End If
End If
X = Bul.Row + Say - 1
Next
With S3.Range("A1:F" & Son)
.Sort S3.Range("D1"), xlAscending, S3.Range("C1"), , xlDescending, S3.Range("B1"), xlAscending, xlYes
.RemoveDuplicates Columns:=2, Header:=xlYes
End With
S3.Cells.EntireColumn.AutoFit
Son = S2.Cells(1, S3.Columns.Count).End(1).Column
For X = 2 To Son Step 2
Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
If Bul.Offset(0, 4) <> "X" Then
Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
If (Satır - 2) > Ürün_Sayısı Then Exit Do
S2.Cells(Satır, X) = Bul.Offset(0, 1)
S2.Cells(Satır, X + 1) = Bul.Offset(0, 2)
Bul.Offset(0, 4) = "X"
End If
Set Bul = S3.Range("A:A").FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> Adres
End If
Next
Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
For X = 2 To Son
If S3.Cells(X, 5) = "" Then
Bayi = Split(S3.Cells(X, 6), ",")
Say = UBound(Bayi)
If Say > 0 Then
For Y = 0 To Say
Set Bul = S2.Range("1:1").Find(Bayi(Y), , , xlWhole)
If Not Bul Is Nothing Then
Satır = S2.Cells(S2.Rows.Count, Bul.Column).End(3).Row + 1
If (Satır - 2) > Ürün_Sayısı Then GoTo 10
S2.Cells(Satır, Bul.Column) = S3.Cells(X, 2)
S2.Cells(Satır, Bul.Column + 1) = S3.Cells(X, 3)
S3.Cells(X, 5) = "X"
GoTo 20
End If
10 Next
End If
End If
20 Next
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
S2.Cells(Son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
S2.Cells(Son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
S2.Cells(Son + 3, 5) = S3.Cells(S3.Rows.Count, 1).End(3).Row - 1
S2.Cells(Son + 4, 5) = WorksheetFunction.CountIf(S3.Range("E:E"), "X")
S2.Range("B" & Son + 3 & ":D" & Son + 3).Merge
S2.Range("B" & Son + 4 & ":D" & Son + 4).Merge
S2.Range("B" & Son + 3 & ":E" & Son + 4).Font.Bold = True
S2.Range("B" & Son + 3 & ":E" & Son + 4).Borders.LineStyle = 1
Set Bul = Nothing
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub- Katılım
- 14 Eylül 2017
- Mesajlar
- 129
- Excel Vers. ve Dili
- 2016 / Tr
Hocam Allah Razı olsun senden, çeşitlerin hepsi tam olarak yerleşiyor.
Geriye tek bir şey kaldı. Her Bayii'yi 5 ürüne tamamlamak. Sanırım bu kolay kısmı. Bu makro sonucu 5'ten az ürün olan bayiilere, artık çeşide bakmaksızın, kendi içinde yerleşmemiş olan pahalı ürünler ile 5 ürüne tamamlamak.
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,392
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Rica ederim...
Her bayiyi 5 ürüne tamamlarken hangi ürünleri kullanacağız?
Her bayiyi 5 ürüne tamamlarken hangi ürünleri kullanacağız?
- Katılım
- 14 Eylül 2017
- Mesajlar
- 129
- Excel Vers. ve Dili
- 2016 / Tr
Bayii 4 için örnek vereyim. Makro sonucu Dosya4 ve Çanta4 yerleşmiş. 5 ürün olması için 3 ürün daha yerleştirilmeli bu bayii'ye. bayii 4'teki tüm ürünleri ele alıyoruz. yerleşen ürünleri listeden çıkarıyoruz. Kalan ürünleri en pahalıdan ucuza sıralayıp. Kaç ürün yerleşecekse (bu bayii için 3 adet) ilk 3'ünü yerleştiriyoruz. Aynı şekilde diğer bayiiler içinde tabi ki.
silgi2-dosya2-kalem3 yerleşiyor bu durumda.
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,392
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Deneyiniz.
Kod:
Option Explicit
Sub BAYİ_ÜRÜN_LİSTESİ_HAZIRLA()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WF As WorksheetFunction
Dim Ürün_Sayısı As Integer, X As Long, Bul As Range, Adres As String, Z As Long
Dim Son As Long, Satır As Long, Say As Long, Bayi As Variant, Y As Long
Set S1 = Sheets("Tüm Listeler")
Set S2 = Sheets("Oluşacak Liste")
Set S3 = Sheets("Sıralı Liste")
Set WF = WorksheetFunction
Ürün_Sayısı = Application.InputBox("Lütfen bayii başına kaç adet ürün listelemek istediğinizi giriniz.", "ÜRÜN ADEDİ BELİRLEME", 5)
If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Cells.Clear
S3.Cells.Clear
S2.Range("A1") = "Sıra No"
S2.Range("A1:A2").Merge
S2.Range("A3") = 1
S2.Range("A3").AutoFill Destination:=S2.Range("A3:A" & Ürün_Sayısı + 2), Type:=xlFillSeries
S2.Cells.VerticalAlignment = xlCenter
With S2.Range("A1:A" & Ürün_Sayısı + 2)
.Font.Bold = True
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 4
End With
With S3.Range("A1:F1")
.Value = Array("BAYİİ NO", "TÜR", "FİYAT", "SIKLIK", "KONTROL", "BAYİİ SIRALAMASI")
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
For X = 2 To S1.Cells(1, S1.Columns.Count).End(1).Column Step 2
If S1.Cells(3, X) <> "" Then
S1.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Copy S2.Cells(1, X)
S2.Cells(3, X).Resize(Ürün_Sayısı, 2).ClearContents
S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Borders.LineStyle = 1
Son = S1.Cells(S1.Rows.Count, X).End(3).Row - 2
Satır = S3.Cells(S3.Rows.Count, 1).End(3).Row + 1
S1.Cells(3, X).Resize(Son, 2).Sort S1.Cells(3, X + 1), xlDescending
S1.Cells(3, X).Resize(Son, 2).Copy S3.Cells(Satır, 2)
S3.Range("A" & Satır & ":A" & Satır + Son - 1) = S1.Cells(1, X)
End If
Next
Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
With S3.Range("D2:D" & Son)
.Formula = "=COUNTIF(B:B,B2)"
.Value = .Value
End With
With S3.Range("A1:D" & Son)
.Sort S3.Range("B1"), xlAscending, S3.Range("C1"), , xlDescending, , , xlYes
End With
For X = 2 To Son
Set Bul = S3.Range("B:B").Find(S3.Cells(X, 2), , , xlWhole)
If Not Bul Is Nothing Then
Say = WorksheetFunction.CountIf(S3.Range("B:B"), S3.Cells(X, 2))
If Say = 1 Then
S3.Cells(X, 6) = S3.Cells(X, 1)
Else
With S3.Range("F" & X & ":F" & Bul.Row + Say - 1)
.Value = Join(Application.Transpose(S3.Range("A" & X & ":A" & Bul.Row + Say - 1).Value), ",")
End With
End If
End If
X = Bul.Row + Say - 1
Next
With S3.Range("A1:F" & Son)
.Sort S3.Range("D1"), xlAscending, S3.Range("C1"), , xlDescending, S3.Range("B1"), xlAscending, xlYes
.RemoveDuplicates Columns:=2, Header:=xlYes
End With
S3.Cells.EntireColumn.AutoFit
Son = S2.Cells(1, S2.Columns.Count).End(1).Column
For X = 2 To Son Step 2
Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
If Bul.Offset(0, 4) <> "X" Then
Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
If (Satır - 2) > Ürün_Sayısı Then Exit Do
S2.Cells(Satır, X) = Bul.Offset(0, 1)
S2.Cells(Satır, X + 1) = Bul.Offset(0, 2)
Bul.Offset(0, 4) = "X"
End If
Set Bul = S3.Range("A:A").FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> Adres
End If
Next
Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
For X = 2 To Son
If S3.Cells(X, 5) = "" Then
Bayi = Split(S3.Cells(X, 6), ",")
Say = UBound(Bayi)
If Say > 0 Then
For Y = 0 To Say
Set Bul = S2.Range("1:1").Find(Bayi(Y), , , xlWhole)
If Not Bul Is Nothing Then
Satır = S2.Cells(S2.Rows.Count, Bul.Column).End(3).Row + 1
If (Satır - 2) > Ürün_Sayısı Then GoTo 10
S2.Cells(Satır, Bul.Column) = S3.Cells(X, 2)
S2.Cells(Satır, Bul.Column + 1) = S3.Cells(X, 3)
S3.Cells(X, 5) = "X"
GoTo 20
End If
10 Next
End If
End If
20 Next
Son = S2.Cells(1, S3.Columns.Count).End(1).Column
For X = 2 To Son Step 2
For Y = 3 To Ürün_Sayısı
If S2.Cells(Y, 1) <> "" Then
If S2.Cells(Y, X) = "" Then
Satır = Y
Set Bul = S1.Range("1:1").Find(S2.Cells(1, X), , , xlWhole)
If Not Bul Is Nothing Then
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
For Z = 3 To Son
If WF.CountIf(S2.Columns(X), S1.Cells(Z, Bul.Column)) = 0 Then
S2.Cells(Satır, X) = S1.Cells(Z, Bul.Column)
S2.Cells(Satır, X + 1) = S1.Cells(Z, Bul.Column + 1)
Satır = Satır + 1
If (Satır - 2) > Ürün_Sayısı Then Exit For
End If
Next
End If
End If
End If
Next
Next
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
S2.Cells(Son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
S2.Cells(Son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
S2.Cells(Son + 3, 5) = S3.Cells(S3.Rows.Count, 1).End(3).Row - 1
S2.Cells(Son + 4, 5) = WorksheetFunction.CountIf(S3.Range("E:E"), "X")
S2.Range("B" & Son + 3 & ":D" & Son + 3).Merge
S2.Range("B" & Son + 4 & ":D" & Son + 4).Merge
S2.Range("B" & Son + 3 & ":E" & Son + 4).Font.Bold = True
S2.Range("B" & Son + 3 & ":E" & Son + 4).Borders.LineStyle = 1
Set Bul = Nothing
Set WF = Nothing
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub- Katılım
- 14 Eylül 2017
- Mesajlar
- 129
- Excel Vers. ve Dili
- 2016 / Tr
Hocam kodu çalıştırdım. Aşağıdaki gibi bir liste çıktı. Eksikler var. Bayii 4-5 ve 6'yı olması gerektiği gibi doldurmuş fakat diğer bayilere devam etmemiş sanırım.
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,392
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Döngüde satır sayısını eksik düzenlemişim. Sorun bundan kaynaklanıyor. Aşağıdaki kodu deneyiniz.
Not : Forumda cevap yazarken sürekli olarak alıntı yapmanıza gerek yok. Gerektiği zaman alıntı yapmayı deneyiniz.
Not : Forumda cevap yazarken sürekli olarak alıntı yapmanıza gerek yok. Gerektiği zaman alıntı yapmayı deneyiniz.
Kod:
Option Explicit
Sub BAYİ_ÜRÜN_LİSTESİ_HAZIRLA()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WF As WorksheetFunction
Dim Ürün_Sayısı As Integer, X As Long, Bul As Range, Adres As String, Z As Long
Dim Son As Long, Satır As Long, Say As Long, Bayi As Variant, Y As Long
Set S1 = Sheets("Tüm Listeler")
Set S2 = Sheets("Oluşacak Liste")
Set S3 = Sheets("Sıralı Liste")
Set WF = WorksheetFunction
Ürün_Sayısı = Application.InputBox("Lütfen bayii başına kaç adet ürün listelemek istediğinizi giriniz.", "ÜRÜN ADEDİ BELİRLEME", 5)
If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Cells.Clear
S3.Cells.Clear
S2.Range("A1") = "Sıra No"
S2.Range("A1:A2").Merge
S2.Range("A3") = 1
S2.Range("A3").AutoFill Destination:=S2.Range("A3:A" & Ürün_Sayısı + 2), Type:=xlFillSeries
S2.Cells.VerticalAlignment = xlCenter
With S2.Range("A1:A" & Ürün_Sayısı + 2)
.Font.Bold = True
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 4
End With
With S3.Range("A1:F1")
.Value = Array("BAYİİ NO", "TÜR", "FİYAT", "SIKLIK", "KONTROL", "BAYİİ SIRALAMASI")
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
For X = 2 To S1.Cells(1, S1.Columns.Count).End(1).Column Step 2
If S1.Cells(3, X) <> "" Then
S1.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Copy S2.Cells(1, X)
S2.Cells(3, X).Resize(Ürün_Sayısı, 2).ClearContents
S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Borders.LineStyle = 1
Son = S1.Cells(S1.Rows.Count, X).End(3).Row - 2
Satır = S3.Cells(S3.Rows.Count, 1).End(3).Row + 1
S1.Cells(3, X).Resize(Son, 2).Sort S1.Cells(3, X + 1), xlDescending
S1.Cells(3, X).Resize(Son, 2).Copy S3.Cells(Satır, 2)
S3.Range("A" & Satır & ":A" & Satır + Son - 1) = S1.Cells(1, X)
End If
Next
Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
With S3.Range("D2:D" & Son)
.Formula = "=COUNTIF(B:B,B2)"
.Value = .Value
End With
With S3.Range("A1:D" & Son)
.Sort S3.Range("B1"), xlAscending, S3.Range("C1"), , xlDescending, , , xlYes
End With
For X = 2 To Son
Set Bul = S3.Range("B:B").Find(S3.Cells(X, 2), , , xlWhole)
If Not Bul Is Nothing Then
Say = WorksheetFunction.CountIf(S3.Range("B:B"), S3.Cells(X, 2))
If Say = 1 Then
S3.Cells(X, 6) = S3.Cells(X, 1)
Else
With S3.Range("F" & X & ":F" & Bul.Row + Say - 1)
.Value = Join(Application.Transpose(S3.Range("A" & X & ":A" & Bul.Row + Say - 1).Value), ",")
End With
End If
End If
X = Bul.Row + Say - 1
Next
With S3.Range("A1:F" & Son)
.Sort S3.Range("D1"), xlAscending, S3.Range("C1"), , xlDescending, S3.Range("B1"), xlAscending, xlYes
.RemoveDuplicates Columns:=2, Header:=xlYes
End With
S3.Cells.EntireColumn.AutoFit
Son = S2.Cells(1, S2.Columns.Count).End(1).Column
For X = 2 To Son Step 2
Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
If Bul.Offset(0, 4) <> "X" Then
Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
If (Satır - 2) > Ürün_Sayısı Then Exit Do
S2.Cells(Satır, X) = Bul.Offset(0, 1)
S2.Cells(Satır, X + 1) = Bul.Offset(0, 2)
Bul.Offset(0, 4) = "X"
End If
Set Bul = S3.Range("A:A").FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> Adres
End If
Next
Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
For X = 2 To Son
If S3.Cells(X, 5) = "" Then
Bayi = Split(S3.Cells(X, 6), ",")
Say = UBound(Bayi)
If Say > 0 Then
For Y = 0 To Say
Set Bul = S2.Range("1:1").Find(Bayi(Y), , , xlWhole)
If Not Bul Is Nothing Then
Satır = S2.Cells(S2.Rows.Count, Bul.Column).End(3).Row + 1
If (Satır - 2) > Ürün_Sayısı Then GoTo 10
S2.Cells(Satır, Bul.Column) = S3.Cells(X, 2)
S2.Cells(Satır, Bul.Column + 1) = S3.Cells(X, 3)
S3.Cells(X, 5) = "X"
GoTo 20
End If
10 Next
End If
End If
20 Next
Son = S2.Cells(1, S3.Columns.Count).End(1).Column
For X = 2 To Son Step 2
For Y = 3 To Ürün_Sayısı + 2
If S2.Cells(Y, 1) <> "" Then
If S2.Cells(Y, X) = "" Then
Satır = Y
Set Bul = S1.Range("1:1").Find(S2.Cells(1, X), , , xlWhole)
If Not Bul Is Nothing Then
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
For Z = 3 To Son
If WF.CountIf(S2.Columns(X), S1.Cells(Z, Bul.Column)) = 0 Then
S2.Cells(Satır, X) = S1.Cells(Z, Bul.Column)
S2.Cells(Satır, X + 1) = S1.Cells(Z, Bul.Column + 1)
Satır = Satır + 1
If (Satır - 2) > Ürün_Sayısı Then Exit For
End If
Next
End If
End If
End If
Next
Next
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
S2.Cells(Son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
S2.Cells(Son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
S2.Cells(Son + 3, 5) = S3.Cells(S3.Rows.Count, 1).End(3).Row - 1
S2.Cells(Son + 4, 5) = WorksheetFunction.CountIf(S3.Range("E:E"), "X")
S2.Range("B" & Son + 3 & ":D" & Son + 3).Merge
S2.Range("B" & Son + 4 & ":D" & Son + 4).Merge
S2.Range("B" & Son + 3 & ":E" & Son + 4).Font.Bold = True
S2.Range("B" & Son + 3 & ":E" & Son + 4).Borders.LineStyle = 1
Set Bul = Nothing
Set WF = Nothing
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub- Katılım
- 14 Eylül 2017
- Mesajlar
- 129
- Excel Vers. ve Dili
- 2016 / Tr
Korhan hocam kullandıkca farkediyorum. Hani herhangi bir bayii de 5 ürün yerlesmisse yerlesecek ürün bir sonraki pahali bayiiye yerlestirilecekti ya, burada bi sıkıntı var. Evet gidip o bayiiye yerlestiriyor. Ama fiyatı en pahali olani yaziyor. Halbuki yerlestigi bayiideki fiyati yazmasi gerekiyordu.
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,392
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Yine örnekle açıklamanızı rica edeceğim.