Planlama

[yaslan]

Merhaba Arkadaşlar,

Ürünlerin üretim planı ile ilgili bir sorunum var, detayları dosyanın içinde açıkladım.
Önerilere açığım, yardımlarınızı bekliyorum.

Şimdiden teşekkürler

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub aktar()
Dim i, sat, s As Integer
[a3:x10000].Clear
s = 3
For i = 2 To Sheets.Count
For sat = 4 To Sheets(i).Cells(65536, "a").End(xlUp).Row
Range(Sheets(i).Cells(sat, "a"), Sheets(i).Cells(sat, "x")).Copy _
Range(Cells(s, "a"), Cells(s, "x"))
s = s + 1
Next: Next
End Sub

 

[yaslan]

Çok teşekkürler N.Ziya Hiçdurmaz,

Tablo sayfasına aktarılan markalarda, eğer ileri zamanlar için üretim girilmemiş ise gelmesini engelleyebilirmiyiz.

Teşekkürler

 

[N.Ziya Hiçdurmaz]

Engelleriz. İleri zaman olarak nitelendirdiğiniz kriterler nelerdir belirtmemişsiniz

 

[yaslan]

Markanın sağ tarafındaki kolonlarda "üretim" veya herhangi birşey yazmıyorsa tablo sayfasına gelmesin.

Teşekkürler

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub aktar()
Dim i, sat, sut, deg, s As Integer
[a3:x10000].Clear
s = 3
Application.ScreenUpdating = False
For i = 2 To Sheets.Count
For sat = 4 To Sheets(i).Cells(65536, "a").End(xlUp).Row
deg = WorksheetFunction.CountA(Range(Sheets(i).Cells(sat, "b"), _
Sheets(i).Cells(sat, "x")))
If deg > 0 Then
Range(Sheets(i).Cells(sat, "a"), Sheets(i).Cells(sat, "x")).Copy _
Range(Cells(s, "a"), Cells(s, "x"))
s = s + 1
End If: Next: Next
Application.ScreenUpdating = True
End Sub

 

[yaslan]

Sayın N.Ziya Hiçdurmaz

Emeğiniz için çok teşekkürler, tam istediğim gibi olmuş.

Sadece bir konu var, eger vaktiniz olurda yaparsanız sevinirim.

Tablo sayfasına bilgileri getirirken içinde bulunduğumuz hafta dahil ve sonrasını getirirse çok güzel olacak. Anladığım kadarıyla şuan bütününü getiriyor.

Şimdiden teşekkürler

 

[yaslan]

Sayın N.Ziya Hiçdurmaz

Yardımcı olabilecekmisiniz?

 

[N.Ziya Hiçdurmaz]

Yanıt

Tablo sayfasından seçilen haftaları getirir

Sub aktar()
Dim i, sat, sut, deg, s As Integer
[a3:x10000].Clear
s = 3
Application.ScreenUpdating = False
For i = 2 To Sheets.Count
For sut = 2 To 24
For sat = 4 To Sheets(i).Cells(65536, "a").End(xlUp).Row
deg = WorksheetFunction.CountA(Range(Sheets(i).Cells(sat, "b"), _
Sheets(i).Cells(sat, "x")))
If Cells(2, sut) = Sheets(i).Cells(2, sut) And deg > 0 Then
Range(Sheets(i).Cells(sat, "a"), Sheets(i).Cells(sat, sut)).Copy _
Range(Cells(s, "a"), Cells(s, sut))
s = s + 1
End If: Next: Next: Next
Application.ScreenUpdating = True
End Sub

 

[yaslan]

Çok teşekkürler N.Ziya Hiçdurmaz elinize sağlık.

İyi bayramlar.

 

[zamenya]

düşey ara vba

sayın hocalarım aşaıdaki kodu düşey arama fonksiyonu gibi kullanıyorum verileri eşleştiriyor ama çok yavaş çalışıyor bunu nasıl hızlandıra bilirm

rivate Sub al1_Click()
Dim hcr As Range, s2 As Worksheet, k As Range
Sheets("DATA").Select
Set s2 = Sheets("VERİ")
Application.ScreenUpdating = False
For Each hcr In Range("D2" & Cells(65536, "D").End(xlUp).Row)
Set k = s2.Range("B:B").Find(hcr.Value, , xlValues, xlWhole)
If Not k Is Nothing Then
hcr.Offset(0, 1).Value = k.Offset(0, 1).Value
hcr.Offset(0, 2).Value = k.Offset(0, 2).Value
hcr.Offset(0, 3).Value = k.Offset(0, 7).Value
hcr.Offset(0, 4).Value = k.Offset(0, 9).Value
hcr.Offset(0, 5).Value = k.Offset(0, 10).Value



End If
Next hcr
Set s2 = Nothing
Set k = Nothing
Application.ScreenUpdating = True
MsgBox "Hesaplama İşlemi Tamamdır.."
End Sub

 

[zamenya]

kusura bakmayın konuyu incelerken burayada kendi konumu açmışım