Fİrma Adina GÖre Kaydetme

[mercan3459]

arkadaşlar bir çok firmaların kayıtlı olduğu excel dosyası elimde mevcut. ben bu firmaları firma ismine göre farklı bi excel sayfasına aktarmak istiyorum. yardımlarınızı bekliyorum.

 

[RSE002]

filitleyerek baska sheetlere ayırma makrosu

yukarıdaki konu baslıgını incelermisiniz.

 

[mercan3459]

filitleyerek baska sheetlere ayırma makrosu

yukarıdaki konu baslıgını incelermisiniz.

RSE002
link ekleyebilirmisin? konu başlığını bulamadım.

 

[Ferhat Pazarçevirdi]

"Farklı bir Excel sayfası" derken, aynı çalışma kitabı içerisindeki başka bir sheet (sayfa) i mi, yoksa başka bir çalışma kitabını mı kastediyorsunuz?

 

[RSE002]

http://www.excel.web.tr/showthread.php?t=45662

 

[RSE002]

birde bu
http://www.excel.web.tr/showthread.php?t=19635
umarım isine yarar

 

[mercan3459]

RSE002 teşekkürler yardım için istediğm buymuş. inceleyip kendime göre ayarlamayı deneyeceğim.
arkadaşlar birde sitede bulduğum benim sorunumu çözen formüllü excelide ekliyorum. tam olarak cevap vermedi. çünkü amacım yeni excel sayfasına direk kaydetmekti.

 

[mercan3459]

arkadaşlar tek bi yerde takıldım firmaya göre yeni bir excel sayfasına nasıl ekleriz. yani workbook olacak şekilde buna halledersem.nihai sonuca ulaşmış oluyorum bi el atarmısınız?

 

[PHÖNİX1]

arkadaşım belki benim yaptırdığım exel işine yarar

bir klasör içinde "müşteri borç bilgileri" exel dosyası var
onu açıyorsun
oraya isim yazdığında bir kitap1 dosyasına ne işlersen aynı sını
bir daha açıyor ama isim ne açarsan o klasöre isim yazarak dosya oluşturuyor
bir incele belki işine yarar.
aşağıdaki yere gir

http://www.excel.web.tr/showthread.php?p=253612#post253612

 

[mercan3459]

sostelefon teşükkürler ilgin için
olay şu sanırım yeterince açıklayamadım.
A çalışma sayfasını başka bi excel çalışma kitabına A adıyla kaydedilmesini istiyorum.

 

[mercan3459]

BaŞka ÇaliŞma Kİtabina Aktarma

arkadaşlar
ekteki exceli yeni bi çalışma kitabına firma adına göre kaydetmesi için uğraştım. Fakat fazla bilgim olmadığında dolayı beceremedim. ekteki listeyi bu şekilde düzenleyip gönderebilr misiniz??

 

[PHÖNİX1]

aynı şeyden bahsediyoruz sadece benim ana dosyamda müşteri adını yazdığımda kitap1 ne olursa aynı kitap1 deki şekle göre yazıyor orda sadece o klasör içine
yeni bir kitap oluşturuyor ve müşteri adını yazıyor (kitap1 yerine)
ve hatta exel dosyası içine bile müşteri adını yazıyor. senin bahsettiğin sadece tarihleri v.s yazmıyor .
istersen bir dene benim söylediğim yerden klasörü upload et
ama bir klasör içinde olacak veya

http://www.excel.web.tr/showthread.php?p=253612#post253612

ferhat beyin yazdıklarını uygularsan anlarsın

azçok anlamış olsam sana yardım edeceğim.

ben bu kadar yardım edebilirim.

bende senin söylediğin gibi adresi vergi dairesini telf.no aktarsın istedim ama
cevap alamadım.

sen istersen ferhat bey üstüne tıklayarak mesaj yaz o yardımcı olur.

çünkü proğramı o yazdı

yaptırabiliyorsan ben de adresi telf. no kayıt aktama gibi istiyorum

saygılar

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları, standart bir modül sayfasına kopyalayıp çalıştırınız. Aynı çalışma kitabı içerisine, farklı bütün müşteriler için sayfa açar ve bilgilerini girer.

Option Explicit
Sub Sayfalara_Ayirmak()
    Dim col As New Collection
    Dim shF As Worksheet, _
        shT As Worksheet, _
        bul As Range
    Dim i%, j%, k%, son%
    Dim adres As String
    Set shF = Sheets("FİRMALAR")
    On Error Resume Next
    For i = 2 To shF.Cells(65536, 1).End(xlUp).Row
        col.Add shF.Cells(i, 1), shF.Cells(i, 1)
    Next i
    On Error GoTo 0
    For i = 1 To col.Count
        Set shT = Sheets.Add(after:=Sheets(Sheets.Count))
        shT.Name = col.Item(i)
        shT.Range("A1:E1").Value = shF.Range("A1:E1").Value
        Set bul = shF.Columns(1).Find(col.Item(i), Lookat:=xlWhole)
        If Not bul Is Nothing Then
            adres = bul.Address
            Do
                son = shT.Cells(65536, 1).End(xlUp).Row + 1
                For k = 1 To 5
                    shT.Cells(son, k) = shF.Cells(bul.Row, k)
                Next k
                Set bul = shF.Columns(1).FindNext(bul)
            Loop While Not bul Is Nothing And adres <> bul.Address
        End If
    Next i
    shF.Select
    Set bul = Nothing
    Set shT = Nothing
    Set shF = Nothing
End Sub

 

[mercan3459]

ya çok oluyorum ama peki başka bi çalışma kitabına aktarılabilrmi diyelimki örneğin firma adıyla "c:/zamak tekstil.xls" oluşturlabilir mi? Ve diğer firmalar için kendi adlarıyla ayrı ayrı tek makro ile excel çalışma kitabı oluşturlabilir mi?

 

[Ferhat Pazarçevirdi]

O zaman, daha önce yazdığımız kod yerine aşağıdakini kullanınız.

Sub Kitaplara_Ayirmak()
Dim klasor
Dim dizin As String
Dim col As New Collection
Dim shF As Worksheet, _
    shT As Worksheet, _
    wbB As Workbook, _
    wbT As Workbook, _
    bul As Range
Dim i%, j%, k%, son%
Dim adres As String
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
If klasor Is Nothing Then
   MsgBox "Herhangi bir klasör seçmediniz", vbCritical, "UYARI"
   Exit Sub
Else
    dizin = klasor.self.Path
End If
Set wbB = ThisWorkbook
Set shF = wbB.Sheets("FİRMALAR")
On Error Resume Next
For i = 2 To shF.Cells(65536, 1).End(xlUp).Row
    col.Add shF.Cells(i, 1), shF.Cells(i, 1)
Next i
On Error GoTo 0
Application.ScreenUpdating = False
For i = 1 To col.Count
        
    Set wbT = Workbooks.Add
    Set shT = wbT.ActiveSheet
    
    shT.Name = col.Item(i)
    shT.Range("A1:E1").Value = shF.Range("A1:E1").Value
    Set bul = shF.Columns(1).Find(col.Item(i), Lookat:=xlWhole)
    If Not bul Is Nothing Then
        adres = bul.Address
        Do
            son = shT.Cells(65536, 1).End(xlUp).Row + 1
            For k = 1 To 5
                shT.Cells(son, k) = shF.Cells(bul.Row, k)
            Next k
            Set bul = shF.Columns(1).FindNext(bul)
        Loop While Not bul Is Nothing And adres <> bul.Address
    End If
    Application.DisplayAlerts = False
    wbT.SaveAs dizin & Application.PathSeparator & col.Item(i) & ".xls"
    Application.DisplayAlerts = True
    
    wbT.Close 0
    
Next i
Application.ScreenUpdating = True
Set bul = Nothing
Set shT = Nothing
Set shF = Nothing
Set wbB = Nothing
Set wbT = Nothing
Set brw = Nothing
End Sub

 

[mercan3459]

olay budur ya
Ferhat Bey gerçekten çok teşekkürler. Makro düzgün çalıştı. iş yükümü o kadar çok hafifletecekki çok teşekkür ederim.
Yalnızca bi husus var tarih sütunu genel olarak görünüyo oda düzeltilirse problem kalmayacak.