Listeleme sorunu

[KARTAL06]

Arkadaşlar arama yaptım ama uygun bir örnek bulamadım. Sorunum şu belirli parçalarım var ve belirli zamanlarda işleniyor. Her işlem sonunda işlme bilgileri kaydedliyor. Ben bu kayıt işlemlerini tek bir listeye giriyorum. Yapmak istediğim büyük listeden bu parçalara ait sayfalara büyük listeden aktarıp bazı zaman hesapları yapmak. Özet tablo denedim işmi tam anlamıyla görmedi. Yardımlarınızı bekliyorum. Yapmak istediğimi ekte anlatmaya çalıştım.

 

[N.Ziya Hiçdurmaz]

yanıt

Örneğe bir bakınız.

Sub aktar()
Set s1 = Sheets("anasayfa")
For i = 2 To Sheets.Count
Sheets(i).Range("a2:d5000").Clear
For bak = 1 To s1.[b65536].End(3).Row
If Sheets(i).Name = Range("b" & bak).Value Then
s1.Range("b" & bak).EntireRow.Copy
s = WorksheetFunction.CountA(Sheets(i).[a1:a65536])
Sheets(i).Range("a" & s + 1).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
End Sub

 

[KARTAL06]

Elinize sağlık süper ama

Ama ben kod yazmayı bilmiyorum. Bu kodu ekledim diyelim benim esas listem çok daha büyük nasıl uyarlarım? Uyarlamak zor olurmu?

 

[N.Ziya Hiçdurmaz]

Ana sayfanın B sütununda parça isimleri var.Siz sadece yeni parça isimleri ile aynı isimde sayfalar oluşturun yeter.

 

[KARTAL06]

Sıralamayı parça numarasına göre yapmam lazım

Yani sayfa adları parça numaralarından oluşacak. İkincisi sütun sayısıda artacak örnekte 5 sütun var benim listemde 25 sütun. İnşahhah çok şey istemiyorum.

 

[KARTAL06]

gerçek listeden bir kesit ekledim

Sayfa adlarını parça numaralarına göre açmam lazım. Yazdığınız kod buna göre düznlenebilirmi?

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
Set s1 = Sheets("anasayfa")
For i = 2 To Sheets.Count
Sheets(i).Range("a2:w5000").Clear
For bak = 4 To s1.[h65536].End(3).Row
If Sheets(i).Name = Range("h" & bak).Value Then
s1.Range("h" & bak).EntireRow.Copy
s = WorksheetFunction.CountA(Sheets(i).[a1:a65536])
Sheets(i).Range("a" & s + 1).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Bu daha iyi oldu.

Sub aktar()
On Error Resume Next
Set s1 = Sheets("anasayfa")
Set s2 = Sheets("sayfalar")
For i = 4 To s1.[h65536].End(3).Row
s1.Range("h" & i).Copy
s = s + 1
s2.Range("a" & s).PasteSpecial
Next
For sil = s2.[a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(s2.Range("a1:a" & sil), s2.Range("a" & sil)) > 1 Then
s2.Rows(sil).Delete
End If
Next
On Error GoTo hata
For ek = 1 To s2.[a65536].End(3).Row
If s2.Range("a" & ek) <> "" Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = s2.Range("a" & ek)
End If
Next
Exit Sub
hata:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
MsgBox "Aynı sayfadan mevcuttur"

For i = 1 To Sheets.Count
If Sheets(i).Name <> s1.Name And Sheets(i).Name <> s2.Name Then
Sheets(i).Range("a2:w5000").Clear
End If
Next

For ii = 1 To Sheets.Count
For bak = 1 To s1.[h65536].End(3).Row
If Sheets(ii).Name = s1.Range("h" & bak).Value Then
s1.Range("h" & bak).EntireRow.Copy
If Sheets(ii).Name <> s1.Name And Sheets(ii).Name <> s2.Name Then
s = WorksheetFunction.CountA(Sheets(ii).[a1:a65536]) + 1
Sheets(ii).Range("a" & s).PasteSpecial
End If
End If
Next
Next
s1.Select
Application.CutCopyMode = False
End Sub

 

[KARTAL06]

teşekkürler

Sabah ilk iş foruma girdim dosyayı indirdim.Şimdi deneyeceğim. İlginize teşekkürler.

 

[KARTAL06]

Bu kod işime yaradı. Küçük bir detay var

Sub aktar()
Set s1 = Sheets("anasayfa")
For i = 2 To Sheets.Count
Sheets(i).Range("a2:w5000").Clear
For bak = 4 To s1.[h65536].End(3).Row
If Sheets(i).Name = Range("h" & bak).Value Then
s1.Range("h" & bak).EntireRow.Copy
s = WorksheetFunction.CountA(Sheets(i).[a1:a65536])
Sheets(i).Range("a" & s + 1).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
End Sub

Satır başlıklarını sayfalara eklemek için A2 den başlamsı mümkünmü? Yada satır başlıklarınıda yazdırabilirmiyiz?
Diğer kod sayfaları kendi açıyor. Devamlı veri girişi yaptığımdan her seferinde sayfaları silip yeniden taratmam gerekiyor.

 

[N.Ziya Hiçdurmaz]

yanıt

İlk satırı boş bırakır.

Sub aktar()
Set s1 = Sheets("anasayfa")
For i = 2 To Sheets.Count
Sheets(i).Range("a2:w5000").Clear
For bak = 4 To s1.[h65536].End(3).Row
If Sheets(i).Name = Range("h" & bak).Value Then
s1.Range("h" & bak).EntireRow.Copy
s = WorksheetFunction.CountA(Sheets(i).[a1:a65536])
Sheets(i).Range("a" & s + 2).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Kodlar dosyadaki hücre adreslerine göredir.

Sub aktar()
Set s1 = Sheets("anasayfa")
For i = 2 To Sheets.Count
Sheets(i).Range("a2:w5000").Clear
For say = 2 To Sheets.Count
s1.[a3:v3].Copy
Sheets(say).[a1].PasteSpecial
Next
For bak = 4 To s1.[h65536].End(3).Row
If Sheets(i).Name = Range("h" & bak).Value Then
s1.Range("h" & bak).EntireRow.Copy
s = WorksheetFunction.CountA(Sheets(i).[a1:a65536])
Sheets(i).Range("a" & s + 1).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
End Sub

 

[KARTAL06]

Süper oldu bir sorum daha var?

İnşallah sizi kızdırmıyorum? Bakım sütunundan sonra bu verilerin ortalamalarını almak için formül giriyorum. Yeniden aktarma yaptığımda formülün silinmemesi mümkünmüdür?

 

[N.Ziya Hiçdurmaz]

yanıt

İstediğiniz gibi ayarladım bir deneyiniz.

Sub aktar()
Set s1 = Sheets("anasayfa")
For i = 2 To Sheets.Count
Sheets(i).Range("a2:w5000").Clear
For say = 2 To Sheets.Count
s1.[a3:v3].Copy
Sheets(say).[a1].PasteSpecial
Next
For bak = 4 To s1.[h65536].End(3).Row
If Sheets(i).Name = Range("h" & bak).Value Then
Range(s1.Range("h" & bak).Offset(0, -7), s1.Range("h" & bak).Offset(0, 14)).Copy
s = WorksheetFunction.CountA(Sheets(i).[a1:a65536])
Sheets(i).Range("a" & s + 1).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
End Sub

 

[KARTAL06]

Sorun çıktı!

Sorun şu. Ana sayfadaki veriler önceden silinmiyordu şimdi siliniyor ayrıca bakım satırından sonra aktarılan sayfaya veri girip tekrar aktarma yaptığımda veri siliniyor. Birde dikkatimi çeken başka bir konu ilk iki satırı aktarmadı (3kez denedim aynı)

 

[AS3434]

Sayın KARTAL06

Dosyanız ekte.

 

[KARTAL06]

Teşekürler

Her iki arkadaşada yardımları için teşekkür ederim.

 

[KARTAL06]

Nereyi değiştirmem gerekiyor?

Sayın KARTAL06

Dosyanız ekte.

Kodda neryi değiştirirsem (tezgah) sırasına göre listeleme yapar?

 

[AS3434]

If Cells(i, 8).Value = Sheets(z).Name Then

Kırmızı yeri 4 yaparsanız.

yani sütun sayısı.

 

[KARTAL06]

Tamam Çok işime yarayacak

Şimdi işim çok kolaylaştı.