• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile yapabilir miyim?

Z

zulkarneyn37

Katılım
17 Eylül 2013
Mesajlar
47
Excel Vers. ve Dili
Profesyonel Plus 2021
Arkadaşlar Merhaba.

Biraz karmaşık ama anlatmaya çalışacağım. Dosyada 9 sayfa var. İlk sayfa "bahçe" burada ilk sütunda parsel numaraları, ikinci sütunda o parselde yetişen ürünler, üçüncü sütunda da yetişen ürün guruplarına göre verilen kod var. dördüncü sütunda ise ürünlerin karakter sayıları var. dördüncü sütunu sıralama yapmak için kullanıyorum. dördüncü sütuna göre sıralama yapıp her farklı ürün grubuna kod veriyorum. karakter sayısına göre sıralama yapmamın nedeni, az çeşit olandan başlayıp çok çeşit olana göre artması gerektiği için. bu kodlar bahçe için, boş olanlar "B0" dan başlayıp artarak gidiyor ve en sonuncu projeye göre değişiklik gösterebiliyor. yani ürün sütunu boş olan bütün satılara "B0" "Bağ" olan olan satırlara "B1" "Bağ, Ceviz, Ayva" olan satırlara "B2" ....... seklinde artarak yazıyorum. ürünler projeye göre değiştiği için bir projede "Bağ, Ceviz, Ayva" B1 olurken başka projede farklı bir ürün grubu B1 olabiliyor. kodları verdikten sonra "bahçe_lej" sayfasında bu kodların hangi ürünleri ifade ettiğini gösteren bir tablo oluşturuyorum. burayı düşeyara ile kolayca halledebiliyorum. bu kısımı otomatik yapmak zor ise yapmasak da olabilir. kod verme işini "tarla" "sebze" "kuru_tarım" sayfalarında da aynı mantıkla yapıyorum. tarla kodları "T0", sebze kodları "S0", kuru tarım kodları "K0" dan başlayarak aynı şekilde artarak gidiyor. en son sayfa olan "POT_TOP" sayfasında parsel numarasına göre verdiğimiz bahçe tarla sebze ve kuru tarım kodlarını kopyalayarak bunların birleşimini yapıyorum ve böylece her parsel numarasının potansiyel kodunu oluşturmuş oluyorum.

Yaptığım işlemler bunlar. Detaylı anlatmaya çalıştım inşallah anlatabilmişimdir. Yardımcı olabilirseniz sevinirim. Şimdiden teşekkürler.

Örnek dosya ektedir.

potansiyel.xlsx - 332 KB
 
" dördüncü sütuna göre sıralama yapıp her farklı ürün grubuna kod veriyorum. karakter sayısına göre sıralama yapmamın nedeni, az çeşit olandan başlayıp çok çeşit olana göre artması gerektiği için."

Gruplama yaparken virgül sayısına göre yaparsanız daha doğru olur. B3 aslında B4 ten sonra olmalıydı.
 
Linkteki dosyayı inceleyiniz.

* lej ve POT sayfaları silinir. Yeniden oluşturulur.
* POT sayfasındaki başlıklar parsel sayfalarındaki açıklamaların ilk harflerinden alınır.
*Sayfa isimlendirme standardına uyulduğu takdirde sayfa sayıları arttırılıp azaltılabilir.
* Ürün grup kodları, sayfa isimlerinin ilk harflerinden alınır.

http://s2.dosya.tc/server3/o2ervp/Potansiyel_Hazirla.zip.html
 
asri' Alıntı:
Linkteki dosyayı inceleyiniz.

* lej ve POT sayfaları silinir. Yeniden oluşturulur.
* POT sayfasındaki başlıklar parsel sayfalarındaki açıklamaların ilk harflerinden alınır.
*Sayfa isimlendirme standardına uyulduğu takdirde sayfa sayıları arttırılıp azaltılabilir.
* Ürün grup kodları, sayfa isimlerinin ilk harflerinden alınır.

http://s2.dosya.tc/server3/o2ervp/Potansiyel_Hazirla.zip.html
Genişletmek için tıkla ...

Üstat eline koluna sağlık. Çok teşekkür ederim. Allah razı olsun.
 
sakman26' Alıntı:
selam,
alternatif olarak eki inceleyin. (farklı bir yaklaşım olabilir)
Not : Sn. asri tarafından hazırlanan dokumanı incelemedim. Super olduğundan da eminim.

link : http://s3.dosya.tc/server9/pqn81v/Potansiyel_SA.rar.html
Genişletmek için tıkla ...

Dediğin gibi farklı bir yaklaşım olmuş. veri girişi biraz sıkıntı olabilir. ürün sayfalarına başka bir dosyadan kopyalama yaparak veri alıyorum. formatın değişmesi yapıştırmayı zorlaştırır.

Çok teşekkür ederim ilginiz için. Allah razı olsun.
 
Evet.. Ben veri girişi yapılacağını düşünerek tasarlamaya çalıştım. Kopyalama yoluyla epey sıkıntı yaratacaktır. (Zaten sayfanın adı da VeriGiriş)
kolaylar gelsin..
 
Sn asri

Sn asri;

Yaptığınız bu dosyayı verilerimi kopyaladığım dosyaya entegre edebilirseniz ürün gruplarını ve parsel numaralarını ayrı ayrı sayfaya kopyalama işleminden kurtulmuş olurum. Ekteki dosya verilerim kopyaladığım dosya. dört sayfadan oluşuyor. ilk sayfa "programvt" ye projeye göre değişen sayıda veri giriliyor, bu verilere göre "programvt1", "optimum" ve "pothesap" sayfaları oluşuyor. parsel sayısına göre o sayfaları formülleri aşağı çekip veya siliyorum ve son veri olan "pothesap" sayfası oluşuyor. "pothesap" sayfasındaki "EV" "EW" "EX" "EY" sütunlarındaki verileri de sizin hazırlamış olduğunuz dosyaya yapıştırıp lejant ve pot_top sayfalarını oluşturmam gerekiyor. bu işlemi direk eklediğim dosya üzerinden yapabilirsem benim için daha pratik olacak.

Teşekkürler.

Proglama.xlsx - 33.4 MB
 
zulkarneyn37' Alıntı:
Sn asri;

Yaptığınız bu dosyayı verilerimi kopyaladığım dosyaya entegre edebilirseniz ürün gruplarını ve parsel numaralarını ayrı ayrı sayfaya kopyalama işleminden kurtulmuş olurum. .. "pothesap" sayfasındaki "EV" "EW" "EX" "EY" sütunlarındaki verileri de sizin hazırlamış olduğunuz dosyaya yapıştırıp lejant ve pot_top sayfalarını oluşturmam gerekiyor...
Teşekkürler.
Proglama.xlsx - 33.4 MB
Genişletmek için tıkla ...

Ana veri sayfasındaki veri satırı kadar diğer formüller arttırılıp azaltılabilir.
Bu durumda sizn ilk gönderdiğiniz rapor dosyası tamamen sıfırdan oluşturulmalı.

ilk uygun zamanda bakarım.
 
Linkteki dosyayı inceleyiniz.

* Rapor Oluştur butonuna tıklayıp veri dosyasını seçin.
Potansiyel_Sonuc.xlsx dosyası oluşturulacaktır.
* Veri dosyasındaki sayfa isimleri değiştirilmemelidir. Porgramvt, programvt1,optimum,pothesap
* pothesap sayfasında tarla isimlerinin sonunda rakam olmamalıdır.
* Sayfa isimlendirme standardına uyulduğu takdirde sayfa sayıları arttırılıp azaltılabilir.
* Ürün grup kodları, sayfa isimlerinin ilk harflerinden alınır.



http://s3.dosya.tc/server9/rsy4mm/Potansiyel_Hazirla_v2.2.zip.html

Kod: 
Dim veridosyasi, sonucdosyasi As String
Dim sonsatir As Long
Dim sayfaadi As String
Dim grupliste() As String
Dim pottop() As String
Dim turler(10000) As String


Sub anamenu()
    Application.ScreenUpdating = Fasle
    Application.DisplayAlerts = False
    dosyayolu = ActiveWorkbook.Path
    ChDir dosyayolu
    If Application.Dialogs(xlDialogOpen).Show("*.xls;*.xlsx") = False Then Exit Sub
    veridosyasi = ActiveWorkbook.Name
    Workbooks(veridosyasi).Activate
    
    Call Verileri_Guncelle
    Call pothesap_kopyala
    Call sayfa_olustur
    
    Call sayfa_lej_sil
    Call sayfa_lej_olustur
    Call gruplandir
    Call pot_top_olustur
    ActiveWorkbook.SaveAs Filename:=dosyayolu & "\" & "Potansiyel_Sonuc.xlsx"
  
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox ("İşlem Tamamlandı")
End Sub

Sub Verileri_Guncelle()
   Sheets("Programvt").Select
   vtsonsatir = Cells(Rows.Count, "A").End(3).Row
    
   Sheets("programvt1").Select
   sayfasonsatir = Cells(Rows.Count, "A").End(3).Row
   If vtsonsatir > sayfasonsatir Then
       kopyabasla = sayfasonsatir & ":" & sayfasonsatir
       Rows(sayfasonsatir).Select
       kolona = "A" & sayfasonsatir
       Range(kolona).Activate
       kopyabitir = sayfasonsatir & ":" & vtsonsatir
       Selection.AutoFill Destination:=Rows(kopyabitir), Type:=xlFillDefault
       Rows(kopyabitir).Select
       Range(kolona).Select
   End If
   If vtsonsatir < sayfasonsatir Then
       kopyabitir = vtsonsatir + 1 & ":" & sayfasonsatir
       Rows(kopyabitir).Delete
   End If
   
   Sheets("optimum").Select
   sayfasonsatir = Cells(Rows.Count, "A").End(3).Row
   If vtsonsatir > sayfasonsatir Then
       kopyabasla = sayfasonsatir & ":" & sayfasonsatir
       Rows(sayfasonsatir).Select
       kolona = "A" & sayfasonsatir
       Range(kolona).Activate
       kopyabitir = sayfasonsatir & ":" & vtsonsatir
       Selection.AutoFill Destination:=Rows(kopyabitir), Type:=xlFillDefault
       Rows(kopyabitir).Select
       Range(kolona).Select
   End If
   If vtsonsatir < sayfasonsatir Then
       kopyabitir = vtsonsatir + 1 & ":" & sayfasonsatir
       Rows(kopyabitir).Delete
   End If
   
       Sheets("pothesap").Select
       sayfasonsatir = Cells(Rows.Count, "A").End(3).Row
    If vtsonsatir > sayfasonsatir Then
       kopyabasla = sayfasonsatir & ":" & sayfasonsatir
       Rows(sayfasonsatir).Select
       kolona = "A" & sayfasonsatir
       Range(kolona).Activate
       kopyabitir = sayfasonsatir & ":" & vtsonsatir
       Selection.AutoFill Destination:=Rows(kopyabitir), Type:=xlFillDefault
       Rows(kopyabitir).Select
       Range(kolona).Select
    End If
    If vtsonsatir < sayfasonsatir Then
       kopyabitir = vtsonsatir + 1 & ":" & sayfasonsatir
       Rows(kopyabitir).Delete
    End If
End Sub

Sub pothesap_kopyala()
 
    Windows(veridosyasi).Activate
    Sheets("pothesap").Select
    Sheets("pothesap").Copy
    Cells.Select
    Range("EL1").Activate
    Selection.Copy
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    For i = sonsutun To 1 Step -1
      gec = Cells(1, i).Value
      If Right(gec, 1) = "0" Then
         If Val(Right(gec, 2)) >= 10 Then Columns(i).Delete
      Else
         If Val(Right(gec, 1)) >= 1 Or gec = "TOPLAM" Then Columns(i).Delete
      End If
    Next i
       
    sonucdosyasi = ActiveWorkbook.Name
    Workbooks(veridosyasi).Close
End Sub

Sub sayfa_olustur()
    Windows(sonucdosyasi).Activate
    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    For i = sonsutun To 3 Step -1
      gec = Cells(1, i).Value
      Columns("A:A").Select
      Selection.Copy
      Columns(i).Select
      Selection.Insert Shift:=xlToRight
      Application.CutCopyMode = False
    Next i

    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    sonsutun = sonsutun / 2
    For i = sonsutun To 1 Step -1
      bilgi = tum_harfler_kucuk(Cells(1, 2).Value)
      Columns("A:B").Select
      Selection.Cut
      Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
      NewSh.Name = bilgi
      ActiveSheet.Paste
      Columns("A:B").EntireColumn.AutoFit
      Range("B3").Select
      Columns("B:B").ColumnWidth = 71.71
      Sheets("pothesap").Select
      Columns(1).Delete
      Columns(1).Delete
    Next i
    Sheets("pothesap").Delete
End Sub

Public Function tum_harfler_kucuk(cumle)
gecici = ""
For i = 1 To Len(cumle)
          h = Mid(cumle, i, 1)
          Select Case h
            Case "Ğ": gecici = gecici + "g"
            Case "Ü": gecici = gecici + "u"
            Case "Ş": gecici = gecici + "s"
            Case "Ç": gecici = gecici + "c"
            Case "Ö": gecici = gecici + "o"
            Case "I": gecici = gecici + "i"
            Case "İ": gecici = gecici + "i"
            Case Else: gecici = gecici + LCase(h)
            End Select
Next i
tum_harfler_kucuk = gecici
End Function

Public Function ilk_harfler_buyuk(hucre)
  hucre = tum_harfler_kucuk(hucre)
  If InStr(1, Trim(hucre), " ") > 0 Then
     Kelime = Split(Trim(hucre), " ")
  Else
     hucre = ilk_harf_buyuk(hucre)
     GoTo sonatla
  End If
            
  For j = 0 To UBound(Kelime)
      Kelime(j) = ilk_harf_buyuk(Kelime(j))
  Next j
             
  gec = ""
  For i = 0 To UBound(Kelime)
    If i = 0 Then gec = Kelime(i)
    If i > 0 Then gec = gec + " " + Kelime(i)
  Next i
sonatla:
  ilk_harfler_buyuk = gec

End Function
             
Public Function ilk_harf_buyuk(cumle)
gecici = ""
For i = 1 To Len(cumle)
          h = Mid(cumle, i, 1)
          If i = 1 Then
            Select Case h
              Case "ğ": gecici = gecici + "Ğ"
              Case "ü": gecici = gecici + "Ü"
              Case "ş": gecici = gecici + "Ş"
              Case "ç": gecici = gecici + "Ç"
              Case "ö": gecici = gecici + "Ö"
              Case "ı": gecici = gecici + "I"
              Case "i": gecici = gecici + "İ"
              Case Else: gecici = gecici + UCase(h)
            End Select
          Else
             gecici = gecici + h
          End If
Next i
ilk_harf_buyuk = gecici
End Function

Sub sayfa_lej_sil()
   For j = Sheets.Count To 1 Step -1
       If Right(Sheets(j).Name, 4) = "_lej" Then
          Sheets(j).Delete
       End If
   Next j
End Sub

Sub sayfa_lej_olustur()
   For j = Sheets.Count To 1 Step -1
      Set NewSh = Sheets.Add(After:=Sheets(j))
      NewSh.Name = Sheets(j).Name & "_lej"
      Cells(1, 1).Value = "KOD"
      Cells(1, 2).Value = "AÇIKLAMA"
      Columns("B:B").ColumnWidth = 75
   Next j
 

End Sub

Sub sirala_adet_bitki(sayfastr As String)
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    kolond = "D2:D" & sonsatir
    kolonb = "B2:B" & sonsatir
    kolona = "A1:D" & sonsatir
    
    Columns("A:D").Select
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Add Key:=Range(kolond) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Add Key:=Range(kolonb) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sayfastr).Sort
        .SetRange Range(kolona)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B15").Select
End Sub

Sub sirala_kolon(sayfastr As String, sutunne As String)
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    kolona = "A1:D" & sonsatir
    kolonb = sutunne & "2:" & sutunne & sonsatir
    
    Columns("A:D").Select
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Add Key:=Range(kolonb) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sayfastr).Sort
        .SetRange Range(kolona)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
End Sub

Sub gruplandir()
For j = 1 To Sheets.Count
    Sheets(j).Select
    sayfaadi = Sheets(j).Name
    If Cells(1, 1).Value = "PARSEL_NO" And Right(sayfaadi, 4) <> "_lej" Then
       Columns("C:D").Select
       Selection.ClearContents
       Range("C2").Select
    
       Call sirala_kolon(sayfaadi, "B")
       sonsatir = Cells(Rows.Count, "A").End(3).Row
       For i = 2 To sonsatir
         urunler = Cells(i, 2).Value
         adet = UBound(Split(urunler, ","))
         If adet = -1 Then Cells(i, 4).Value = 0 Else Cells(i, 4).Value = adet
         Cells(i, 2).Value = Replace(urunler, ",", ", ")
       Next i
    
       Call sirala_adet_bitki(sayfaadi)
       grupkodu = UCase(Left(sayfaadi, 1))
       grupsay = 0
       urunlereski = "-1"
       siraeski = -1
       ReDim grupliste(sonsatir, 2)
       tarlaadi = Cells(1, 2).Value
       tarlaadi = ilk_harfler_buyuk(tarlaadi)
       For i = 2 To sonsatir
         urunler = Cells(i, 2).Value
         sira = Cells(i, 4).Value
         If urunler = "" Then
            Cells(i, 3).Value = grupkodu & grupsay
            grupliste(grupsay, 1) = grupkodu & grupsay
            grupliste(grupsay, 2) = "Değerlendirme Alınan " & tarlaadi & "nin Hiçbirine Uygun Değil."
            
            GoTo son
         End If
      
         If urunler <> urunlereski Then
            grupsay = grupsay + 1
         End If
      
        If urunler <> urunlereski Then
           Cells(i, 3).Value = grupkodu & grupsay
           grupliste(grupsay, 1) = grupkodu & grupsay
           grupliste(grupsay, 2) = urunler
        End If
      
        If urunler = urunlereski Then
           Cells(i, 3).Value = grupkodu & grupsay
           grupliste(grupsay, 1) = grupkodu & grupsay
           grupliste(grupsay, 2) = urunler
        End If
son:
        urunlereski = urunler
        siraeski = sira
      Next i
      Call sirala_kolon(sayfaadi, "A")
      Sheets(sayfaadi & "_lej").Select
      For i = 0 To grupsay
         Cells(i + 2, 1).Value = grupliste(i, 1)
         Cells(i + 2, 2).Value = grupliste(i, 2)
      Next i

    End If
Next j

End Sub

Sub pot_top_olustur()
   Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
   NewSh.Name = "POT_TOP"

   For j = 1 To Sheets.Count
      Sheets(j).Select
      If Cells(1, 1).Value = "PARSEL_NO" And Left(Sheets(j).Name, 7) <> "POT_TOP" Then
         Columns("A:A").Select
         Selection.Copy
         Sheets("POT_TOP").Select
         Range("A1").Select
         ActiveSheet.Paste
         Range("A2").Select
         Exit For
      End If
   Next j
   
   tursay = 0
   For j = 1 To Sheets.Count
      Sheets(j).Select
      If Cells(1, 1).Value = "PARSEL_NO" And Left(Sheets(j).Name, 7) <> "POT_TOP" And Sheets(j).Name <> "tarim disi" Then
         tur = Split(Cells(1, 2).Value & " ", " ")
         baslik = Left(tur(0), 1) & Left(tur(1), 1)
         tursay = tursay + 1
         baslik = baslik & "_KOD"
         Sheets("POT_TOP").Select
         Cells(1, tursay + 1).Value = baslik
         sonsatir = Cells(Rows.Count, "A").End(3).Row
         Cells(2, tursay + 1).Select

         ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1," & "'" & Sheets(j).Name & "'" & "!C1:C3,3,0)"
         Selection.AutoFill Destination:=Range(Cells(2, tursay + 1), Cells(sonsatir, tursay + 1))
         Range("B2").Select
      End If
   Next j
   
   Sheets("POT_TOP").Select
   Cells(1, tursay + 2).Value = "POTANSİYEL"
   For i = 2 To sonsatir
      birlesik = ""
      For j = 2 To tursay + 1
        birlesik = birlesik + Cells(i, j).Value
      Next j
      Cells(i, tursay + 2).Value = birlesik
   Next i
    
   Cells.Select
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   Range("A2").Select
   Application.CutCopyMode = False
   Range("C3").Select
    
End Sub
 
Son düzenleme:
asri' Alıntı:
Linkteki dosyayı inceleyiniz.

* Rapor Oluştur butonuna tıklayıp veri dosyasını seçin.
Potansiyel_Sonuc.xlsx dosyası oluşturulacaktır.
* Veri dosyasındaki sayfa isimleri değiştirilmemelidir. Porgramvt, programvt1,optimum,pothesap
* pothesap sayfasında tarla isimlerinin sonunda rakam olmamalıdır.
* Sayfa isimlendirme standardına uyulduğu takdirde sayfa sayıları arttırılıp azaltılabilir.
* Ürün grup kodları, sayfa isimlerinin ilk harflerinden alınır.

http://s3.dosya.tc/server9/46zrpt/Potansiyel_Hazirla_v2.zip.html


Kod: 
Dim veridosyasi, sonucdosyasi As String
Dim sonsatir As Long
Dim sayfaadi As String
Dim grupliste() As String
Dim pottop() As String
Dim turler(10000) As String


Sub anamenu()
    Application.ScreenUpdating = Fasle
    Application.DisplayAlerts = False
    dosyayolu = ActiveWorkbook.Path
    ChDir dosyayolu
    If Application.Dialogs(xlDialogOpen).Show("*.xls;*.xlsx") = False Then Exit Sub
    veridosyasi = ActiveWorkbook.Name
    Workbooks(veridosyasi).Activate
    
    Call Verileri_Guncelle
    Call pothesap_kopyala
    Call sayfa_olustur
    
    Call sayfa_lej_sil
    Call sayfa_lej_olustur
    Call gruplandir
    Call pot_top_olustur
    ActiveWorkbook.SaveAs Filename:=dosyayolu & "\" & "Potansiyel_Sonuc.xlsx"
  
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox ("İşlem Tamamlandı")
End Sub

Sub Verileri_Guncelle()
   Sheets("Programvt").Select
   vtsonsatir = Cells(Rows.Count, "A").End(3).Row
    
   Sheets("programvt1").Select
   sayfasonsatir = Cells(Rows.Count, "A").End(3).Row
   If vtsonsatir > sayfasonsatir Then
       kopyabasla = sayfasonsatir & ":" & sayfasonsatir
       Rows(sayfasonsatir).Select
       kolona = "A" & sayfasonsatir
       Range(kolona).Activate
       kopyabitir = sayfasonsatir & ":" & vtsonsatir
       Selection.AutoFill Destination:=Rows(kopyabitir), Type:=xlFillDefault
       Rows(kopyabitir).Select
       Range(kolona).Select
   End If
   If vtsonsatir < sayfasonsatir Then
       kopyabitir = vtsonsatir + 1 & ":" & sayfasonsatir
       Rows(kopyabitir).Delete
   End If
   
   Sheets("optimum").Select
   sayfasonsatir = Cells(Rows.Count, "A").End(3).Row
   If vtsonsatir > sayfasonsatir Then
       kopyabasla = sayfasonsatir & ":" & sayfasonsatir
       Rows(sayfasonsatir).Select
       kolona = "A" & sayfasonsatir
       Range(kolona).Activate
       kopyabitir = sayfasonsatir & ":" & vtsonsatir
       Selection.AutoFill Destination:=Rows(kopyabitir), Type:=xlFillDefault
       Rows(kopyabitir).Select
       Range(kolona).Select
   End If
   If vtsonsatir < sayfasonsatir Then
       kopyabitir = vtsonsatir + 1 & ":" & sayfasonsatir
       Rows(kopyabitir).Delete
   End If
   
       Sheets("pothesap").Select
       sayfasonsatir = Cells(Rows.Count, "A").End(3).Row
    If vtsonsatir > sayfasonsatir Then
       kopyabasla = sayfasonsatir & ":" & sayfasonsatir
       Rows(sayfasonsatir).Select
       kolona = "A" & sayfasonsatir
       Range(kolona).Activate
       kopyabitir = sayfasonsatir & ":" & vtsonsatir
       Selection.AutoFill Destination:=Rows(kopyabitir), Type:=xlFillDefault
       Rows(kopyabitir).Select
       Range(kolona).Select
    End If
    If vtsonsatir < sayfasonsatir Then
       kopyabitir = vtsonsatir + 1 & ":" & sayfasonsatir
       Rows(kopyabitir).Delete
    End If
End Sub

Sub pothesap_kopyala()
 
    Windows(veridosyasi).Activate
    Sheets("pothesap").Select
    Sheets("pothesap").Copy
    Cells.Select
    Range("EL1").Activate
    Selection.Copy
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    For i = sonsutun To 1 Step -1
      gec = Cells(1, i).Value
      If Right(gec, 1) = "0" Then
         If Val(Right(gec, 2)) >= 10 Then Columns(i).Delete
      Else
         If Val(Right(gec, 1)) >= 1 Or gec = "TOPLAM" Then Columns(i).Delete
      End If
    Next i
       
    sonucdosyasi = ActiveWorkbook.Name
    Workbooks(veridosyasi).Close
End Sub

Sub sayfa_olustur()
    Windows(sonucdosyasi).Activate
    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    For i = sonsutun To 3 Step -1
      gec = Cells(1, i).Value
      Columns("A:A").Select
      Selection.Copy
      Columns(i).Select
      Selection.Insert Shift:=xlToRight
      Application.CutCopyMode = False
    Next i

    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    sonsutun = sonsutun / 2
    For i = sonsutun To 1 Step -1
      bilgi = tum_harfler_kucuk(Cells(1, 2).Value)
      Columns("A:B").Select
      Selection.Cut
      Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
      NewSh.Name = bilgi
      ActiveSheet.Paste
      Columns("A:B").EntireColumn.AutoFit
      Range("B3").Select
      Columns("B:B").ColumnWidth = 71.71
      Sheets("pothesap").Select
      Columns(1).Delete
      Columns(1).Delete
    Next i
    Sheets("pothesap").Delete
End Sub

Public Function tum_harfler_kucuk(cumle)
gecici = ""
For i = 1 To Len(cumle)
          h = Mid(cumle, i, 1)
          Select Case h
            Case "Ğ": gecici = gecici + "g"
            Case "Ü": gecici = gecici + "u"
            Case "Ş": gecici = gecici + "s"
            Case "Ç": gecici = gecici + "c"
            Case "Ö": gecici = gecici + "o"
            Case "I": gecici = gecici + "i"
            Case "İ": gecici = gecici + "i"
            Case Else: gecici = gecici + LCase(h)
            End Select
Next i
tum_harfler_kucuk = gecici
End Function


Sub sayfa_lej_sil()
   For j = Sheets.Count To 1 Step -1
       If Right(Sheets(j).Name, 4) = "_lej" Then
          Sheets(j).Delete
       End If
   Next j
End Sub

Sub sayfa_lej_olustur()
   For j = Sheets.Count To 1 Step -1
      Set NewSh = Sheets.Add(After:=Sheets(j))
      NewSh.Name = Sheets(j).Name & "_lej"
      Cells(1, 1).Value = "KOD"
      Cells(1, 2).Value = "AÇIKLAMA"
      Columns("B:B").ColumnWidth = 75
   Next j
 

End Sub

Sub sirala_adet_bitki(sayfastr As String)
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    kolond = "D2:D" & sonsatir
    kolonb = "B2:B" & sonsatir
    kolona = "A1:D" & sonsatir
    
    Columns("A:D").Select
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Add Key:=Range(kolond) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Add Key:=Range(kolonb) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sayfastr).Sort
        .SetRange Range(kolona)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B15").Select
End Sub

Sub sirala_kolon(sayfastr As String, sutunne As String)
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    kolona = "A1:D" & sonsatir
    kolonb = sutunne & "2:" & sutunne & sonsatir
    
    Columns("A:D").Select
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sayfastr).Sort.SortFields.Add Key:=Range(kolonb) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sayfastr).Sort
        .SetRange Range(kolona)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
End Sub

Sub gruplandir()
For j = 1 To Sheets.Count
    Sheets(j).Select
    sayfaadi = Sheets(j).Name
    If Cells(1, 1).Value = "PARSEL_NO" And Right(sayfaadi, 4) <> "_lej" Then
       Columns("C:D").Select
       Selection.ClearContents
       Range("C2").Select
    
       Call sirala_kolon(sayfaadi, "B")
       sonsatir = Cells(Rows.Count, "A").End(3).Row
       For i = 2 To sonsatir
         urunler = Cells(i, 2).Value
         adet = UBound(Split(urunler, ","))
         If adet = -1 Then Cells(i, 4).Value = 0 Else Cells(i, 4).Value = adet
       Next i
    
       Call sirala_adet_bitki(sayfaadi)
       grupkodu = UCase(Left(sayfaadi, 1))
       grupsay = 0
       urunlereski = "-1"
       siraeski = -1
       ReDim grupliste(sonsatir, 2)
       
       For i = 2 To sonsatir
         urunler = Cells(i, 2).Value
         sira = Cells(i, 4).Value
         If urunler = "" Then
            Cells(i, 3).Value = grupkodu & grupsay
            grupliste(grupsay, 1) = grupkodu & grupsay
            grupliste(grupsay, 2) = "Değerlendirme Alınan Sebze Bitkilerinin Hiçbirine Uygun Değil."
            
            GoTo son
         End If
      
         If urunler <> urunlereski Then
            grupsay = grupsay + 1
         End If
      
        If urunler <> urunlereski Then
           Cells(i, 3).Value = grupkodu & grupsay
           grupliste(grupsay, 1) = grupkodu & grupsay
           grupliste(grupsay, 2) = urunler
        End If
      
        If urunler = urunlereski Then
           Cells(i, 3).Value = grupkodu & grupsay
           grupliste(grupsay, 1) = grupkodu & grupsay
           grupliste(grupsay, 2) = urunler
        End If
son:
        urunlereski = urunler
        siraeski = sira
      Next i
      Call sirala_kolon(sayfaadi, "A")
      Sheets(sayfaadi & "_lej").Select
      For i = 0 To grupsay
         Cells(i + 2, 1).Value = grupliste(i, 1)
         Cells(i + 2, 2).Value = grupliste(i, 2)
      Next i

    End If
Next j

End Sub

Sub pot_top_olustur()
   Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
   NewSh.Name = "POT_TOP"

   For j = 1 To Sheets.Count
      Sheets(j).Select
      If Cells(1, 1).Value = "PARSEL_NO" And Left(Sheets(j).Name, 7) <> "POT_TOP" Then
         Columns("A:A").Select
         Selection.Copy
         Sheets("POT_TOP").Select
         Range("A1").Select
         ActiveSheet.Paste
         Range("A2").Select
         Exit For
      End If
   Next j
   
   tursay = 0
   For j = 1 To Sheets.Count
      Sheets(j).Select
      If Cells(1, 1).Value = "PARSEL_NO" And Left(Sheets(j).Name, 7) <> "POT_TOP" Then
         tur = Split(Cells(1, 2).Value & " ", " ")
         baslik = Left(tur(0), 1) & Left(tur(1), 1)
         tursay = tursay + 1
         baslik = baslik & "_KOD"
         Sheets("POT_TOP").Select
         Cells(1, tursay + 1).Value = baslik
         sonsatir = Cells(Rows.Count, "A").End(3).Row
         Cells(2, tursay + 1).Select

         ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1," & "'" & Sheets(j).Name & "'" & "!C1:C3,3,0)"
         Selection.AutoFill Destination:=Range(Cells(2, tursay + 1), Cells(sonsatir, tursay + 1))
         Range("B2").Select
      End If
   Next j
   
   Sheets("POT_TOP").Select
   Cells(1, tursay + 2).Value = "POTANSİYEL"
   For i = 2 To sonsatir
      birlesik = ""
      For j = 2 To tursay + 1
        birlesik = birlesik + Cells(i, j).Value
      Next j
      Cells(i, tursay + 2).Value = birlesik
   Next i
    
End Sub
Genişletmek için tıkla ...

üstat eline sağlık;
bir iki sorunum var.

* önceden ürünler arasında olan virgüllere değiştir ile boşluk ekliyordum. bunu ekleme şansımız varsa güzel olur.

* pot_top sayfasında tarım dışı için kodlar olmayacak. yani sadece bahçe, tarla, sebze ve kuru tarım bitkileri kodları ve bunların birleşimi olacak. (tarım_dışı ve tarım_dışı_lej sayfaları olacak)

* Birde lejant sayfalarında verdiğimiz "B0" "S0" "T0" "K0" kodlarının karşında yazan açıklamaların hepsinde "Değerlendirme Alınan Sebze Bitkilerinin Hiçbirine Uygun Değil." yazıyor. yani hepsinde sebze yazmış. Bunu her ürün grubuna ayrı yazdırmamız gerekiyor.

Değerlendirmeye Alınan Bahçe Bitkilerinin Hiçbirine Uygun Değil.
Değerlendirmeye Alınan Tarla Bitkilerinin Hiçbirine Uygun Değil.
Değerlendirmeye Alınan Sebze Bitkilerinin Hiçbirine Uygun Değil.
Değerlendirmeye Alınan Kuru Tarım Bitkilerinin Hiçbirine Uygun Değil.
Değerlendirmeye Alınan Tarım Dışı Kullanımlarının Hiçbirine Uygun Değil.

Şeklinde yazabilir miyiz?
 
Son düzenleme:
Bir önceki mesajımda güncellemeler yapıldı.
 
asri' Alıntı:
Bir önceki mesajımda güncellemeler yapıldı.
Genişletmek için tıkla ...

Teşekkür ederim.

Tarım dışı ve tarım dışı lej sayfaları oluşmuyor. Bu sayfaların oluşup, pot_top sayfasında olmaması gerekiyor. Pot_top sayfası şuan istediğim gibi. sadece ürün kodlarında olan düşeyara formülü yerine direk yazmak mümkünse iyi olur.

Ürünlere virgülden sonra bir boşluk ekleme şansımız var mı?

Hocam tekrar teşekkür ederim. Bu hali bile çok işimi kolaylaştırdı.
 
Mesajımdaki dosya güncellendi.

TD_KOD çıkarıldı. Formüller kaldırıldı. Virügüller den sonra boşluklar eklendi.
 
düşeyara yavaş

merhaba

iki sayfadaki veriyi stok kodlarına göre karşılaştırıp veri aynı olanlardan veri çekmek istiyorum. Düşeyara çok yavaş çalışıyor.

macro örneği varmı acaba.


teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst