• DİKKAT

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

Grup İçinde Gruba Ayırma

D

dasdemir34

Katılım
15 Temmuz 2013
Mesajlar
25
Excel Vers. ve Dili
excel 2007 türkçe
Merhaba ;

Anlatımım , derdimi anlatışım çok karışıksa şimdiden özür dilerim.

Dosya linki :
http://s5.dosya.tc/server2/87pa9s/Satis_Stok_Siparis_Analizi.xlsx.html
Satış , stok ,sipariş analizi yaptığım bir dosya var.
0Z1eyv.png


Bu işlemlerin hepsi bittikten sonra , ilgili kişilere kendi firmalarının satış ,stok ,sipariş analizini , hem kendi zaman kaybımı hemde ilgili kişilerin zaman kaybını en aza indirerek çok temiz ve güzel rapor halinde mail ortamında sunmak istiyorum.

Yardımınızı rica ederim , Teşekkürler ...
 
Son düzenleme:
Veli bey ve Cemal bey aynı firmalara bakması mı gerekiyor?
 
Merhaba.

En azından ilgili kişilere göre (M sütunu) yeni sayfalar oluşturularak
ilgili kişiye ait satırlardaki verilerin aktarılması işlemi için aşağıdaki kod'u kullanabilirsiniz.

Kişi sayfalarındaki firmalar için yeni sayfa oluşturularak o firmaya ait verilerin aktarılması olayını halledebilirsem bakacağım.
Olmazsa başka üyeler destek verir sanırım.
.
Kod: 
[FONT="Arial Narrow"]Sub İLGİLİ_KİŞİ()
Set ana = Sheets("Sayfa1")
ana.Activate
With Application
    .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
End With
    For sayfa = Worksheets.Count To 1 Step -1
        On Error GoTo 20
        If Worksheets.Count = 1 Then Exit For
            If Sheets(sayfa).Name = "Sayfa1" Then GoTo 10
20              Sheets(sayfa).Delete
10  Next
Application.DisplayAlerts = True

For ilgili = 3 To ana.[M65536].End(3).Row
    If WorksheetFunction.CountIf(ana.Range("M3:M" & ilgili), ana.Cells(ilgili, "M")) = 1 Then
        Sheets.Add
            Sayfa_Adı = ana.Cells(ilgili, "M").Value
            ActiveSheet.Name = Sayfa_Adı
                Set ikişi = Sheets(Sayfa_Adı)
                        ana.Activate
                    ana.Range("$A$2:$M$2").AutoFilter Field:=13, Criteria1:=ana.Cells(ilgili, "M").Value
                ana.Range("A1:L2").Copy: ikişi.Activate: ActiveSheet.Paste
            ana.Range("A3:L8").SpecialCells(xlCellTypeVisible).Copy Destination:=ikişi.Range("A3")
        ikişi.[A1] = ActiveSheet.Name: [A1].Select: Cells.EntireColumn.AutoFit
    End If
Next
ana.Range("$A$2:$M$2").AutoFilter Field:=13: Sheets("Sayfa1").Move Before:=Sheets(1)
With Application
    .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic
End With
MsgBox "İLGİLİ KİŞİler için sayfalar oluşturuldu ve veriler aktarıldı."
End Sub[/FONT]
 
Son düzenleme:
Sayfaları aşağıdaki kod ile ekleyip ömer beyin kodlarını ekleyip deneyiniz.
İsme göre 2 sayfa açıyor. Yani M sütundaki isme ve E sütunundaki firma ismine göre oluşturuyor.

Kod: 
Sub sayfaac()
    Dim sayfa As String, s1 As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  For i = 3 To Sayfa1.Range("A1048576").End(3).Row
  a = Mid(Cells(i, "M"), 1, WorksheetFunction.Find(" ", Cells(i, "M"), 1) - 1)
  b = Mid(Cells(i, "E"), 1, WorksheetFunction.Find(" ", Cells(i, "E"), 1) - 1)
   syf = a & " Bey " & b & " Firması"
               sayfa = syf
               If Not varmi(sayfa) Then
                   Sheets.Add After:=Worksheets(Worksheets.Count)
                   ActiveSheet.Name = syf
      End If
   Next
  Application.ScreenUpdating = True
End Sub
 
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function
 
Tekrar merhaba.
Önceki cevabımda birkaç düzeltme yaptım.
Kod'u kullanacaksanız sayfayı yenileyerek kontrol ediniz.
.
 
Son düzenleme:
Ömer BARAN' Alıntı:
Merhaba.

En azından ilgili kişilere göre (M sütunu) yeni sayfalar oluşturularak
ilgili kişiye ait satırlardaki verilerin aktarılması işlemi için aşağıdaki kod'u kullanabilirsiniz.

Kişi sayfalarındaki firmalar için yeni sayfa oluşturularak o firmaya ait verilerin aktarılması olayını halledebilirsem bakacağım.
Olmazsa başka üyeler destek verir sanırım.
.
Kod: 
[FONT="Arial Narrow"]Sub İLGİLİ_KİŞİ()
Set ana = Sheets("Sayfa1")
ana.Activate
With Application
    .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
End With
    For sayfa = Worksheets.Count To 1 Step -1
        On Error GoTo 20
        If Worksheets.Count = 1 Then Exit For
            If Sheets(sayfa).Name = "Sayfa1" Then GoTo 10
20              Sheets(sayfa).Delete
10  Next
Application.DisplayAlerts = True

For ilgili = 3 To ana.[M65536].End(3).Row
    If WorksheetFunction.CountIf(ana.Range("M3:M" & ilgili), ana.Cells(ilgili, "M")) = 1 Then
        Sheets.Add
            Sayfa_Adı = ana.Cells(ilgili, "M").Value
            ActiveSheet.Name = Sayfa_Adı
                Set ikişi = Sheets(Sayfa_Adı)
                        ana.Activate
                    ana.Range("$A$2:$M$2").AutoFilter Field:=13, Criteria1:=ana.Cells(ilgili, "M").Value
                ana.Range("A1:L2").Copy: ikişi.Activate: ActiveSheet.Paste
            ana.Range("A3:L8").SpecialCells(xlCellTypeVisible).Copy Destination:=ikişi.Range("A3")
        ikişi.[A1] = ActiveSheet.Name: [A1].Select: Cells.EntireColumn.AutoFit
    End If
Next
ana.Range("$A$2:$M$2").AutoFilter Field:=13: Sheets("Sayfa1").Move Before:=Sheets(1)
With Application
    .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic
End With
MsgBox "İLGİLİ KİŞİler için sayfalar oluşturuldu ve veriler aktarıldı."
End Sub[/FONT]
Genişletmek için tıkla ...


Ömer Bey , kodu kullandım teşekkür ederim.

İlgili kişileri yeni sayfa olarak veriyor. Bu haliyle bile işimi %50 hafifletiyor :) . Firmaları bu sayfalar alında alt sayfa gibi yada buna benzer şekilde açma şansımız var mı ?

Yada şöyle birşey yapabilir miyiz ?
Örnek dosyada 6 firma ve 3 ilgili kişi var.
İlgili kişileri yeni sayfa olarak eklemek yerine , firmaları ilgili kişinin adı , sayfa adının başında olacak şekilde sayfa olarak eklese ?
sayfa adları : Ali Bey_A firma , Ali Bey B firma , Veli Bey C firma ... gibi
 
vardar07' Alıntı:
Sayfaları aşağıdaki kod ile ekleyip ömer beyin kodlarını ekleyip deneyiniz.
İsme göre 2 sayfa açıyor. Yani M sütundaki isme ve E sütunundaki firma ismine göre oluşturuyor.

Kod: 
Sub sayfaac()
    Dim sayfa As String, s1 As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  For i = 3 To Sayfa1.Range("A1048576").End(3).Row
  a = Mid(Cells(i, "M"), 1, WorksheetFunction.Find(" ", Cells(i, "M"), 1) - 1)
  b = Mid(Cells(i, "E"), 1, WorksheetFunction.Find(" ", Cells(i, "E"), 1) - 1)
   syf = a & " Bey " & b & " Firması"
               sayfa = syf
               If Not varmi(sayfa) Then
                   Sheets.Add After:=Worksheets(Worksheets.Count)
                   ActiveSheet.Name = syf
      End If
   Next
  Application.ScreenUpdating = True
End Sub
 
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function
Genişletmek için tıkla ...

vardar07 , ilginiz ve cevap verdiğiniz için teşekkür ederim .
Sizi yormak istemem ama " Sayfaları aşağıdaki kod ile ekleyip .... " kısmını malesef anlayamadım. Makroda internetten bakarak ekledim ve çalıştırdım :)
Eğer tarif etme gibi bir imkanınız var ise veya bunla ilgili okuyabileceğim yada izleyebileceğim bir kaynak belirtebilirseniz çok memnun olurum .

Yardımınız için teşekkür ederim .
 
Merhaba.

Sanırım istediğiniz ekli belgedeki gibi birşey.

Ekteki belgeye buradan da ulaşabilirsiniz.

Sayfa1'de E sütunundaki firma adına fareyle çift tıklayarak ilgili firma sayfasına gidebilir,
firma sayfalarında iken, A1 hücresindeki sayfa adına fareyle tıklayarak Sayfa1'e dönebilirsiniz.
Sayfa adları uzun olduğundan kullanım pratikliği bakımından alt tarafta sayfa adlarının göründüğü alan gizleniyor.
.
 

Ekli dosyalar

Son düzenleme:
İyi günler dilerim.
.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst