DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub OTO_SUZ() '********OTO. SÜZ Butonuna*******
Set s1 = Sheets("Tablo 2")
son_sat = s1.Range("A65536").End(3).Row
son_sut = s1.Cells(2, 256).End(1).Column
s1.Range(s1.Cells(2, "A"), s1.Cells(son_sat, son_sut)).AutoFilter
End Sub
Sub imalforma_aktar() '********FORM'a AKTAR Butonuna*******
Dim iform As Worksheet
Set iform = Sheets("imalform")
If Selection.Rows.Count > 6 Then
MsgBox Selection.Rows.Count & " Adet Satır Seçtiniz!" & _
Chr(10) & "En Fazla 6 Adet Satır Seçebilirsiniz", vbCritical, "DİKKAT!": Exit Sub
End If
iform.Range("C9:D11").ClearContents
iform.Range("H9:I9").ClearContents
iform.Range("B15:I20").ClearContents
iform.Range("A36:I45").ClearContents
iform.Range("A51:B51").ClearContents
iform.Cells(10, "C") = Selection.Cells(1, 1) 'Sipariş Tarihi
iform.Cells(9, "C") = Selection.Cells(1, 2) 'Sipariş No.
iform.Cells(9, "H") = Selection.Cells(1, 4) 'Ünite
iform.Cells(11, "C") = Selection.Cells(1, 3) 'İstek Yapan
iform.Cells(21, "A") = Selection.Cells(1, 8) '1.Malzeme Açıklama
iform.Cells(51, "A") = Selection.Cells(1, 3) 'Talep Eden
For i = 1 To Selection.Rows.Count
iform.Cells(14 + i, "B") = Selection.Cells(i, 7) 'Malzeme Adları
iform.Cells(14 + i, "H") = Selection.Cells(i, 5) 'Miktarlar
iform.Cells(14 + i, "I") = Selection.Cells(i, 6) 'Birimi
iform.Cells(35 + i, "A") = Selection.Cells(i, 9) 'Proje No.
iform.Cells(35 + i, "D") = Selection.Cells(i, 10) 'Poz no.
Next
If MsgBox("Seçtiğiniz " & Selection.Rows.Count & " Satırın Bilgileri ""imalform"" Sayfasına Aktarılmıştır." & _
Chr(10) & Chr(10) & " ""imalform"" Sayfasına Gitmek İster misiniz?", vbInformation + vbYesNo, "İŞLEM TAMAM...") _
<> vbNo Then
iform.Select
End If
End Sub
Dosyanın kendimce makrolar eklenmiş son hali ektedir. Eğer yapapilirsem bu tablolara print ve boyalı olmayanları yeni bir sayfaya aktarmak istiyorum.
Gelen siparişlerin üzerini boyayıp Gelmeyenlerin lisyesini alabilmek için
makro ekleyip boyasızları yeni bir sayfaya aktarmak istiyorum.
Ergün Hocam Merhaba
İlginize teşekkür eder başarılar dilerim.Vaktinizi ve fırsatınız olursa yardımlarınızı beklerim.
1- Tablo 1 deki makrolar konusunda haklısınız dolaylı bir yöntem oldu.Sizin yaptığınızdan faydalanarak düzeltmeye çalıştıp fakat beceremedim.
2- Tablo 1 deki ve Tablo 2 deki sayfada gelen ve imalatı yapılan siparişleri belirlemek için zemin
rengini değiştiriyorum.Belirli aralıklarla zemin rengi değiştirilmeyenleri Listelemem gerekiyor.
Bu nedenle :
Tablo 1 de zemin rengi değiştirilmemiş dolu hücreleri Tablo 1 GLMY sayfasına taşımak
Tablo 2 de zemin rengi değiştirilmemiş dolu hücreleri Tablo 2 GLMY sayfasına taşımak istiyorum.
3- Son olarak "sipformu" ve "imalform" sekmelerindeki veri aktarılmış sayfayı 2 kopya print
etmek yazdırmak için FORMU YAZDIR butonu koymak istiyorum.
iyi günler dileklerimle.
Sub Renksiz_aktar_1()
Dim t1, glmy As Worksheet
Set t1 = Sheets("Tablo 1")
Set glmy1 = Sheets("Tablo 1 GLMY")
glmy1.Range("A3:H65536").ClearContents
son = t1.Cells(65536, "A").End(3).Row
If son = 2 Then
MsgBox "Aktarılacak Satır Bulunamadı"
Exit Sub
End If
sat = 2
For i = 3 To son
With t1
If .Cells(i, "A").Interior.ColorIndex = xlNone Then
sat = sat + 1
glmy1.Range("A" & sat & ":H" & sat) = .Range("A" & i & ":H" & i).Value2
End If
End With
Next
MsgBox "Tablo1 Sayfasındaki " & sat - 2 & " Adet Renksiz Satır Tablo 1 GLYM Sayfasına Aktarılmıştır.", vbInformation
End Sub
Sub Renksiz_aktar_2()
Dim t2, glmy2 As Worksheet
Set t2 = Sheets("Tablo 2")
Set glmy2 = Sheets("Tablo 2 GLMY")
glmy2.Range("A3:J65536").ClearContents
son = t2.Cells(65536, "A").End(3).Row
If son = 2 Then
MsgBox "Aktarılacak Satır Bulunamadı"
Exit Sub
End If
sat = 2
For i = 3 To son
With t2
If .Cells(i, "A").Interior.ColorIndex = xlNone Then
sat = sat + 1
glmy2.Range("A" & sat & ":J" & sat) = .Range("A" & i & ":J" & i).Value2
End If
End With
Next
MsgBox "Tablo2 Sayfasındaki " & sat - 2 & " Adet Renksiz Satır Tablo 2 GLYM Sayfasına Aktarılmıştır.", vbInformation
End Sub
Selam,Hocam makroları şifreledim yalnızca sayfa koruma yı yapamadım sayfa korumaya aldığımda makro ile aktardığım verileri almıyor ve korumalı olduğu için ikaz veriyor
Sub Kullanıcı()
MsgBox "Kullanıcı Adınız: " & Environ("username")
End Sub
Sub imalforma_aktar() '********FORM'a AKTAR Butonuna*******
Dim iform As Worksheet
[COLOR="Red"][B]Dim sifre As String[/B][/COLOR]
Set iform = Sheets("imalform")
[COLOR="Red"][B]sifre = "1234"
iform.Unprotect Password:=sifre[/B][/COLOR]
If Selection.Rows.Count > 6 Then
MsgBox Selection.Rows.Count & " Adet Satır Seçtiniz!" & _
Chr(10) & "En Fazla 6 Adet Satır Seçebilirsiniz", vbCritical, "DİKKAT!": Exit Sub
End If
iform.Range("C9:D11").ClearContents
iform.Range("H9:I9").ClearContents
iform.Range("B15:I20").ClearContents
iform.Range("A36:I45").ClearContents
iform.Range("A51:B51").ClearContents
iform.Cells(10, "C") = Selection.Cells(1, 1) 'Sipariş Tarihi
iform.Cells(9, "C") = Selection.Cells(1, 2) 'Sipariş No.
iform.Cells(9, "H") = Selection.Cells(1, 4) 'Ünite
iform.Cells(11, "C") = Selection.Cells(1, 3) 'İstek Yapan
iform.Cells(21, "A") = Selection.Cells(1, 8) '1.Malzeme Açıklama
iform.Cells(51, "A") = Selection.Cells(1, 3) 'Talep Eden
For i = 1 To Selection.Rows.Count
iform.Cells(14 + i, "B") = Selection.Cells(i, 7) 'Malzeme Adları
iform.Cells(14 + i, "H") = Selection.Cells(i, 5) 'Miktarlar
iform.Cells(14 + i, "I") = Selection.Cells(i, 6) 'Birimi
iform.Cells(35 + i, "A") = Selection.Cells(i, 9) 'Proje No.
iform.Cells(35 + i, "D") = Selection.Cells(i, 10) 'Poz no.
Next
If MsgBox("Seçtiğiniz " & Selection.Rows.Count & " Satırın Bilgileri ""imalform"" Sayfasına Aktarılmıştır." & _
Chr(10) & Chr(10) & " ""imalform"" Sayfasına Gitmek İster misiniz?", vbInformation + vbYesNo, "İŞLEM TAMAM...") _
<> vbNo Then
iform.Select
End If
[COLOR="Red"][B]iform.Cells.Locked = True
iform.Protect Password:=sifre ', AllowFiltering:=True[/B][/COLOR]
End Sub
Ergün Hocam uygulamayı yaptım sonuç başarılı çok teşekkür ediyorum.
Tablo 1 için yardımcı olabilecekmisiniz. Benim bilgilerimle olmadı sizin Tablo 2 için uyguladığınızı kopyalayıp Tablo 1 e uyarlamaya çalıştım ama olmadı. Bu konuda mümkünse yardımlarınızı bekliyorum.