Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 20-12-2017, 09:52   #11
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
Ömer BARAN tarafından gönderildi Mesajı Görüntüle
Merhaba.

Sorunuzu, ekran görüntüsü yerine gerçek belgenizle aynı yapıda bir örnek belge
üzerinden sorarsanız daha hızlı ve net çözüme ulaşabilirsiniz.

Örnek belge yükleme yöntemine ilişkin kısa açıklama cevabımın altındaki İMZA bölümünde var.

Bir örnek belge yüklerseniz ben veya başka bir üye sorunuzu cevapsız bırakmayacaktır.
.
Merhaba hocam,

ilk mesajımda dosya linki vardı. link mi kırık ?

Alıntı:
DMR 7 tarafından gönderildi Mesajı Görüntüle


ha bu arada buradan farklı olarak, sipariş no kısmı başka bir sayfadaki verilerden açılır liste ile seçiliyor. ordaki veriyi değiştirmeye izin vermeyebilir. önemli mi bilmiyorum

Bu mesaj en son " 20-12-2017 " tarihinde saat 10:48 itibariyle DMR 7 tarafından düzenlenmiştir....
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-12-2017, 10:36   #12
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Yardım edebilecek herhangi biri var mıdır?
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-01-2018, 08:31   #13
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,318
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Merhaba
Ek dosyayı deneyiniz
http://s7.dosya.tc/server/cn6203/SIPARIS2.zip.html
"A: D" sütunlarından birindeki hücreye (satırdaki dört hücrede dolu olduğu halde) veri girildiğinde
aktarmayı yapacaktır.
Bilgisayar tarih formatı "dd.mm.yyyy" şeklinde olduğu varsayılarak
Mükerrer kayıt için bir ekleme yapılmadı.
Deneyin eksikliklerde, ekleme yaparız.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tr1 As String
If Selection.Cells.Count <> 1 Then MsgBox "Birden fazla hücrede işlem yapılmaz": Exit Sub
If Intersect(Target, [A:D]) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("A" & Target.Row & ":D" & Target.Row), "") <> 0 Then Exit Sub
If Len(Cells(Target.Row, "A")) < 12 Then Cells(Target.Row, "A").Select: _
MsgBox "Seçili hücrede en az 12 harf olmalı, işlem yapılmadı": Exit Sub
x = UBound(Split(Cells(Target.Row, "A"), Chr(10)))
If x = 0 And Cells(Target.Row, "A") <> "" Then _
MsgBox "A" & Target.Row & "hücresinde 2.satır yok, işlem yapılmadı ": Exit Sub
x = Right(Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(0)), 4)
x1 = Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(1))
x2 = Left(x, 2) & "T-" & Right(x, 2) & "M"
x = x1 & ", " & x2
tr1 = Format(Cells(Target.Row, "C"), "mmm.yy")
Set s1 = Sheets("PLANLAMA ÇİZELGESİ")
cl = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For n = 2 To cl + 1
If IsDate(s1.Cells(1, n)) = True Then
If Month(s1.Cells(1, n)) = Month(Cells(Target.Row, "C")) And _
Year(s1.Cells(1, n)) = Year(Cells(Target.Row, "C")) Then Exit For
End If: Next
If n > cl Then MsgBox Cells(Target.Row, "C") & "Ay-yıl 1. sayfada yok işlem yapılmadı": Exit Sub
kç = Cells(Target.Row, "C") - CDate("31.12." & Year(Cells(Target.Row, "C")) - 1)
kç = WorksheetFunction.MRound(kç / 7, 1)
For a = n To n + 3
If CDbl(Left(Trim(s1.Cells(2, a)), Len(kç))) = CDbl(kç) Then st = a: Exit For
Next
For n2 = 2 To cl + 1
If IsDate(s1.Cells(1, n2)) = True Then
If Month(s1.Cells(1, n2)) = Month(Cells(Target.Row, "D")) And _
Year(s1.Cells(1, n2)) = Year(Cells(Target.Row, "D")) Then Exit For
End If: Next
If n2 > cl Then MsgBox Cells(Target.Row, "D") & "Ay-yıl 1. sayfada yok işlem yapılmadı": Exit Sub
kç2 = Cells(Target.Row, "D") - CDate("31.12." & Year(Cells(Target.Row, "D")) - 1)
kç2 = WorksheetFunction.MRound(kç2 / 7, 1)
For a2 = n2 To n2 + 3
If CDbl(Left(Trim(s1.Cells(2, a2)), Len(kç2))) = CDbl(kç2) Then st1 = a2: Exit For
Next
rws = s1.Cells(Rows.Count, "A").End(3).Row + 1
s1.Cells(rws, "A") = x
s1.Cells(rws, "B") = Cells(Target.Row, "B")
s1.Range(s1.Cells(rws, st), s1.Cells(rws, st1)).MergeCells = True
With s1.Cells(rws, st)
.Value = CDate(Cells(Target.Row, "D"))
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -4.99893185216834E-02
End With
10:
End Sub
PLİNT Çevrimiçi   Alıntı Yaparak Cevapla
Eski 11-01-2018, 09:08   #14
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Merhaba
Ek dosyayı deneyiniz
http://s7.dosya.tc/server/cn6203/SIPARIS2.zip.html
"A: D" sütunlarından birindeki hücreye (satırdaki dört hücrede dolu olduğu halde) veri girildiğinde
aktarmayı yapacaktır.
Bilgisayar tarih formatı "dd.mm.yyyy" şeklinde olduğu varsayılarak
Mükerrer kayıt için bir ekleme yapılmadı.
Deneyin eksikliklerde, ekleme yaparız.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tr1 As String
If Selection.Cells.Count <> 1 Then MsgBox "Birden fazla hücrede işlem yapılmaz": Exit Sub
If Intersect(Target, [A:D]) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("A" & Target.Row & ":D" & Target.Row), "") <> 0 Then Exit Sub
If Len(Cells(Target.Row, "A")) < 12 Then Cells(Target.Row, "A").Select: _
MsgBox "Seçili hücrede en az 12 harf olmalı, işlem yapılmadı": Exit Sub
x = UBound(Split(Cells(Target.Row, "A"), Chr(10)))
If x = 0 And Cells(Target.Row, "A") <> "" Then _
MsgBox "A" & Target.Row & "hücresinde 2.satır yok, işlem yapılmadı ": Exit Sub
x = Right(Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(0)), 4)
x1 = Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(1))
x2 = Left(x, 2) & "T-" & Right(x, 2) & "M"
x = x1 & ", " & x2
tr1 = Format(Cells(Target.Row, "C"), "mmm.yy")
Set s1 = Sheets("PLANLAMA ÇİZELGESİ")
cl = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For n = 2 To cl + 1
If IsDate(s1.Cells(1, n)) = True Then
If Month(s1.Cells(1, n)) = Month(Cells(Target.Row, "C")) And _
Year(s1.Cells(1, n)) = Year(Cells(Target.Row, "C")) Then Exit For
End If: Next
If n > cl Then MsgBox Cells(Target.Row, "C") & "Ay-yıl 1. sayfada yok işlem yapılmadı": Exit Sub
kç = Cells(Target.Row, "C") - CDate("31.12." & Year(Cells(Target.Row, "C")) - 1)
kç = WorksheetFunction.MRound(kç / 7, 1)
For a = n To n + 3
If CDbl(Left(Trim(s1.Cells(2, a)), Len(kç))) = CDbl(kç) Then st = a: Exit For
Next
For n2 = 2 To cl + 1
If IsDate(s1.Cells(1, n2)) = True Then
If Month(s1.Cells(1, n2)) = Month(Cells(Target.Row, "D")) And _
Year(s1.Cells(1, n2)) = Year(Cells(Target.Row, "D")) Then Exit For
End If: Next
If n2 > cl Then MsgBox Cells(Target.Row, "D") & "Ay-yıl 1. sayfada yok işlem yapılmadı": Exit Sub
kç2 = Cells(Target.Row, "D") - CDate("31.12." & Year(Cells(Target.Row, "D")) - 1)
kç2 = WorksheetFunction.MRound(kç2 / 7, 1)
For a2 = n2 To n2 + 3
If CDbl(Left(Trim(s1.Cells(2, a2)), Len(kç2))) = CDbl(kç2) Then st1 = a2: Exit For
Next
rws = s1.Cells(Rows.Count, "A").End(3).Row + 1
s1.Cells(rws, "A") = x
s1.Cells(rws, "B") = Cells(Target.Row, "B")
s1.Range(s1.Cells(rws, st), s1.Cells(rws, st1)).MergeCells = True
With s1.Cells(rws, st)
.Value = CDate(Cells(Target.Row, "D"))
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -4.99893185216834E-02
End With
10:
End Sub
Plint hocam,, ellerine emeklerine sağlık çok teşekkür ederim. Ne zamandır yazıcam fırsatım olmadı. Bir şey düzenleyip atmam gerekiyordu. Ben örnek bir dosya oluşturup kendime uyarlayabilirim sanıyordum fakat denediğimde beceremedim. Zaten olayın %90 ı bitmiş. kendi kullandığım orijinal dosyanın linkini atıyorum. Orada yapmak istediğim bir kaç şeyi not düştüm. Yine buraya da yazayım aynılarını. Kodları o şekilde düzenleyebilirsen çok ama çok mutlu olurum.

http://s7.dosya.tc/server/yasuea/SIP...TESI.xlsx.html

SİPARİŞ NO VE DURUM ALANLARINDA AÇILIR LİSTEDEN SEÇİM YAPIYORUM

Bazı siparişler -1 , -2 diye devam ediyor.

Onları da planlama çizelgesinde yaptığım gibi belirtiyorum. Rakamları sondan değil baştan sayarak aldırabiliriz belki.

Son olarak planlama çizelgesi dinamik olduğu için tarih sağa doğru ilerleyecek. Tanımlı alan giderek artacak.

Kopyala yapıştır ile 1'den fazla hücreyi yapıştırabiliyorum. Daha önceki makro tek tek yapmamı istiyordu. Bu değişebilir mi?

Planlama çizelgesinde, teslim tarihinden geriye doğru, 8 haftanın, durumdaki renklere göre boyanması gerekiyor. O sayfadaki teslim tarihini de boyuyorum.

Durumda ilk seçim renksiz oluyor. Daha sonra ben boyuyorum. Boyalı getiremiyorum.
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 11-01-2018, 21:55   #15
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,318
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Merhaba
Ek dosyayı deneyin
"Durum" sütunundan seçim yaptığınızda ilgili sayfaya ekleyecek, aynı spariş varsa
değiştirecektir.
http://s7.dosya.tc/server/u8m9uo/SIP...STESI.zip.html
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 19 Or Target.Row = 1 Then Exit Sub
If Selection.Cells.Count <> 1 Then MsgBox "Birden fazla hücrede işlem yapılmaz": Exit Sub
If Len(Cells(Target.Row, "A")) < 12 Then Cells(Target.Row, "A").Select: _
MsgBox "Seçili hücrede en az 12 harf olmalı, işlem yapılmadı": Exit Sub
x = UBound(Split(Cells(Target.Row, "A"), Chr(10)))
If x = 0 And Cells(Target.Row, "A") <> "" Then _
MsgBox "A" & Target.Row & " hücresinde 2.satır yok, işlem yapılmadı ": Exit Sub
If IsDate(Cells(Target.Row, "R")) = False Then MsgBox "Teslim tarihi hatalı, işlem yapılmadı": Exit Sub
x = Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(0))
x1 = Left(x, 12): x2 = Mid(x, 13, 4)
If IsNumeric(Replace(Trim(Split(x, x1 & x2)(1)), " ", "")) = True Then x3 = Trim(Split(x, x1 & x2)(1))
x4 = Left(x2, 2) & "T - " & Right(x2, 2) & "M"
x5 = Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(1))
x = x5 & ", " & x4 & " " & x3
Set s1 = Sheets("PLANLAMA ÇİZELGESİ")
rw = s1.Cells(Rows.Count, "A").End(3).Row + 1
Set ara = s1.Range("A1:A" & rw).Find(x, , , xlWhole)
If Not ara Is Nothing Then rw = ara.Row
cl = s1.Cells(2, Columns.Count).End(xlToLeft).Column
hf = Cells(Target.Row, "R") - CDate("31.12." & Year(Cells(Target.Row, "R")) - 1)
hf = hf / 7
hf = WorksheetFunction.RoundUp(hf, 0)
For a = 6 To cl
If s1.Cells(1, a) <> "" And IsDate(s1.Cells(1, a)) = True Then yıl = Year(s1.Cells(1, a))
If CDbl(Left(s1.Cells(2, a), 2)) = hf And yıl = Year(Cells(Target.Row, "R")) Then
Exit For
End If
Next
If Not ara Is Nothing Then MsgBox s1.Name & " Sayfasında aynı spariş bulundu, değiştirilecek"
With s1.Range(s1.Cells(rw, "B"), s1.Cells(rw, cl))
.Value = ""
.MergeCells = False
.Interior.ColorIndex = xlNone
End With
s1.Cells(rw, "A") = x
s1.Cells(rw, "B") = Cells(Target.Row, "B").Value
s1.Cells(rw, "C") = Cells(Target.Row, "R").Value
s1.Cells(rw, "C").Interior.Color = Target.DisplayFormat.Interior.Color
s1.Range(s1.Cells(rw, a - 7), s1.Cells(rw, a)).MergeCells = True
s1.Range(s1.Cells(rw, a - 7), s1.Cells(rw, a)).Borders.Weight = xlMedium
s1.Cells(rw, a - 7).Interior.Color = Target.DisplayFormat.Interior.Color
s1.Cells(rw, a - 7) = Cells(Target.Row, "R")
End Sub
PLİNT Çevrimiçi   Alıntı Yaparak Cevapla
Eski 12-01-2018, 09:59   #16
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Merhaba
Ek dosyayı deneyin
"Durum" sütunundan seçim yaptığınızda ilgili sayfaya ekleyecek, aynı spariş varsa
değiştirecektir.
http://s7.dosya.tc/server/u8m9uo/SIP...STESI.zip.html
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 19 Or Target.Row = 1 Then Exit Sub
If Selection.Cells.Count <> 1 Then MsgBox "Birden fazla hücrede işlem yapılmaz": Exit Sub
If Len(Cells(Target.Row, "A")) < 12 Then Cells(Target.Row, "A").Select: _
MsgBox "Seçili hücrede en az 12 harf olmalı, işlem yapılmadı": Exit Sub
x = UBound(Split(Cells(Target.Row, "A"), Chr(10)))
If x = 0 And Cells(Target.Row, "A") <> "" Then _
MsgBox "A" & Target.Row & " hücresinde 2.satır yok, işlem yapılmadı ": Exit Sub
If IsDate(Cells(Target.Row, "R")) = False Then MsgBox "Teslim tarihi hatalı, işlem yapılmadı": Exit Sub
x = Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(0))
x1 = Left(x, 12): x2 = Mid(x, 13, 4)
If IsNumeric(Replace(Trim(Split(x, x1 & x2)(1)), " ", "")) = True Then x3 = Trim(Split(x, x1 & x2)(1))
x4 = Left(x2, 2) & "T - " & Right(x2, 2) & "M"
x5 = Trim(Split(Trim(Cells(Target.Row, "A")), Chr(10))(1))
x = x5 & ", " & x4 & " " & x3
Set s1 = Sheets("PLANLAMA ÇİZELGESİ")
rw = s1.Cells(Rows.Count, "A").End(3).Row + 1
Set ara = s1.Range("A1:A" & rw).Find(x, , , xlWhole)
If Not ara Is Nothing Then rw = ara.Row
cl = s1.Cells(2, Columns.Count).End(xlToLeft).Column
hf = Cells(Target.Row, "R") - CDate("31.12." & Year(Cells(Target.Row, "R")) - 1)
hf = hf / 7
hf = WorksheetFunction.RoundUp(hf, 0)
For a = 6 To cl
If s1.Cells(1, a) <> "" And IsDate(s1.Cells(1, a)) = True Then yıl = Year(s1.Cells(1, a))
If CDbl(Left(s1.Cells(2, a), 2)) = hf And yıl = Year(Cells(Target.Row, "R")) Then
Exit For
End If
Next
If Not ara Is Nothing Then MsgBox s1.Name & " Sayfasında aynı spariş bulundu, değiştirilecek"
With s1.Range(s1.Cells(rw, "B"), s1.Cells(rw, cl))
.Value = ""
.MergeCells = False
.Interior.ColorIndex = xlNone
End With
s1.Cells(rw, "A") = x
s1.Cells(rw, "B") = Cells(Target.Row, "B").Value
s1.Cells(rw, "C") = Cells(Target.Row, "R").Value
s1.Cells(rw, "C").Interior.Color = Target.DisplayFormat.Interior.Color
s1.Range(s1.Cells(rw, a - 7), s1.Cells(rw, a)).MergeCells = True
s1.Range(s1.Cells(rw, a - 7), s1.Cells(rw, a)).Borders.Weight = xlMedium
s1.Cells(rw, a - 7).Interior.Color = Target.DisplayFormat.Interior.Color
s1.Cells(rw, a - 7) = Cells(Target.Row, "R")
End Sub
hocam mükemmel olmuş. Allah sizden razı olsun. çok teşekkür ederim
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 15:29


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Karton Bardak- Çorlu Dil Konuşma Terapisti- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Çorlu- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Rampa- Rotary- Çorlu İnternet Sitesi- Çorlu Sürücü Kursu- Çorlu Sürücü Kursu- Şişli Avukat- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta- Kağıt Bardak- Kaplan Tekstil- Çorlu Perde- Çorlu Havuz- Makina- Danışmazlar-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden