Satırdaki herhangi bir değere göre diğer sayfaya veri aktarımı hk;

[microfiks]

Merhabalar,

Aşağıdaki makro ile var olan çalışma sayfamı, msgbox ile isim değiştirerek diğer çalışma sayfama (hiçbir değişiklik olmadan) aktarabiliyorum. Yapmaya çalıştığım şey ise;

Çalışma Detayı:

Tablomda bulunan ve filtrelemek istediğim veriler sadece "H8:H100" sütununda bulunmaktadır. Geri kalan hiç bir yer değişmemelidir.

Örneğin "Kağıt" geçen sütunlar H8 H9 ve H10 olsun. Yeni sayfaya aktarım yaptığımda aşağıdaki formülde olduğu gibi tüm sayfayı taşısın fakat filtrelenen alanda H8 den H100 ' e kadar değil sadece H8, H9 ve H10 gösterilsin (Gösterilmeyen satırların silinmesi gerekiyor yeni sayfada) .

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

Sub Makro1()

Sheets("RAPOR").Visible = True
Sheets("RAPOR").Copy After:=Worksheets(Worksheets.Count)
10 NewPageName = InputBox("MÜDÜRE GÖNDERMEK İSTEDİĞİNİZ RAPORUN İSMİNİ BELİRLEYİNİZ!" _
& vbCrLf & sayfa, "Kopya", "_")
If NewPageName = cancel Then Exit Sub
For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiğiniz sayfa adı mevcuttur yeniden deneyin."
GoTo 10
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName

End Sub

 

[acolkesen1]

Merhaba,
Aşağıdaki kodu deneyin. Kopyalayacağınız sayfayı sayfa1 olarak kabul ettim.Sütun sayısını ihtiyaca göre kırmızı renkli satırda değiştirebilirsiniz. İyi çalışmalar.

crt = InputBox("Filtre ölçütü")
[sayfa1!a1].AutoFilter field:=2, Criteria1:="*" & crt & "*"
Range("A1:H" & [A65536].End(3).Row).Copy
Worksheets.Add
[a1].PasteSpecial
'Sheets("SAYFA1").Copy After:=Worksheets(Worksheets.Count)
10 NewPageName = InputBox("MÜDÜRE GÖNDERMEK İSTEDİĞİNİZ RAPORUN İSMİNİ BELİRLEYİNİZ!" _
& vbCrLf & sayfa, "Kopya", "_")
If NewPageName = cancel Then Exit Sub
For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiğiniz sayfa adı mevcuttur yeniden deneyin."
GoTo 10
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName
[sayfa1!a1].AutoFilter

 

[microfiks]

Merhaba,
Aşağıdaki kodu deneyin. Kopyalayacağınız sayfayı sayfa1 olarak kabul ettim.Sütun sayısını ihtiyaca göre kırmızı renkli satırda değiştirebilirsiniz. İyi çalışmalar.

crt = InputBox("Filtre ölçütü")
[sayfa1!a1].AutoFilter field:=2, Criteria1:="*" & crt & "*"
Range("A1:H" & [A65536].End(3).Row).Copy
Worksheets.Add
[a1].PasteSpecial
'Sheets("SAYFA1").Copy After:=Worksheets(Worksheets.Count)
10 NewPageName = InputBox("MÜDÜRE GÖNDERMEK İSTEDİĞİNİZ RAPORUN İSMİNİ BELİRLEYİNİZ!" _
& vbCrLf & sayfa, "Kopya", "_")
If NewPageName = cancel Then Exit Sub
For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiğiniz sayfa adı mevcuttur yeniden deneyin."
GoTo 10
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName
[sayfa1!a1].AutoFilter

İlginiz için teşekkür ederim fakat, kod sadece bir sefer çalıştı. İkinci sefer çalışmıyor.

Ayrıca 8.satırda bölmeleri dondurmuştum, diğer sayfaya aktarınca 2 ve 8. satır aralığı kayboluyor.

Sayfa Adım:CCAR

Sub Makro1()

crt = InputBox("Filtre ölçütü")
[CCAR!a1].AutoFilter field:=2, Criteria1:="*" & crt & "*"
Range("A1:H" & [A65536].End(3).Row).Copy
Worksheets.Add
[a1].PasteSpecial
Sheets("CCAR").Copy After:=Worksheets(Worksheets.Count)
10 NewPageName = InputBox("MÜDÜRE GÖNDERMEK İSTEDİĞİNİZ RAPORUN İSMİNİ BELİRLEYİNİZ!" _
& vbCrLf & CCAR, "Kopya", "_")
If NewPageName = cancel Then Exit Sub
For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiğiniz sayfa adı mevcuttur yeniden deneyin."
GoTo 10
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName
[CCAR!a1].AutoFilter

End Sub

 

[acolkesen1]

Merhaba,
Kodda sayı ile ilgili bir kısıtlama yok. Kendi bilgisayarımda deneyerek gönderdim. Sadece yeni sayfada kalıyor. Başlangıç sayfasına dönmek için en sona sheets("ccar").select ekleyebilirsiniz. Diğer sorun için; başlangıçta yeterli açıklama yapmanız gerekirdi. Fırsat bulursam gün içerisinde yardımcı olmaya çalışırım. Dosya ekleme sitelerinden biri üzerinden çalışmanızı ekler ve yeterli açıklamayı yaparsanız daha hızlı ve kesin çözüm için mutlaka bir yardım eden bulunur.