Klasörlere bölüp tekrar birleştirme

[Rainbows]

Merhaba Arkadaşlar,

excel de yüklü bir dosyam var. bu dosyayı klasörlere bölüp klasörler içinde sheet oluşturmak istiyorum. örnek dosyam da tam olarak ne yapmak istedigimi anlatmaya calıştım.

yardımcı olabilirseniz sevinirim.

 

[Rainbows]

selamlar arkadaşlar,

yardımcı olabilecek bir arkadaş varmıdır?

 

[Rainbows]

arkadaşlar, nasıl yapabilecegim konusunda yardımcı olabilecek birisi varmıdır? veya böyle birşey yapılabilir mi?

 

[usubaykan]

Option Explicit

Sub Klasöre_Göre_Ayır()
Dim S As Long, KLASÖR, klasör_kontrol, veri
Dim yeni_klasör As String, il_klasör As String, S1 As Worksheet, Son, ilk
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set S1 = Sheets("Sheet1")
Set KLASÖR = CreateObject("Scripting.FileSystemObject")

S1.Range("AK:AK").ClearContents

'böl
For S = 5 To S1.Cells(Rows.Count, "B").End(3).Row
If S1.Cells(S, "AK") <> "Aktarıldı" Then
    il_klasör = ThisWorkbook.Path & "\" & S1.Cells(S, "B") & "\"
    veri = KLASÖR.FolderExists(il_klasör)
  If veri <> True Then
        KLASÖR.CreateFolder il_klasör
    End If
'Var olmayan klasörleri oluşturdu
  
'excel dosyası oluşturmak için

Sheets("Veri").Delete
Sheets.Add
ActiveSheet.Name = "Veri"
Son = S1.Cells(Rows.Count, "B").End(3).Row
    S1.Range("$A$4:$F$" & Son).AutoFilter Field:=2, Criteria1:="" & S1.Cells(S, "B") & ""
    ilk = S1.Cells(1, "A").End(4).Row
    S1.Range(S1.Cells(ilk, "AK"), S1.Cells(Son, "AK")) = "Aktarıldı"
    S1.Range(S1.Cells(ilk, "A"), S1.Cells(Son, "AJ")).Copy
    
    With Sheets("Veri")
    .Range("A1").PasteSpecial
    .Copy
    End With
        
    ActiveWorkbook.SaveAs Filename:= _
        "" & il_klasör & Range("B3") & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
'Klasör içerisine excel dosyalarını kopyaladı
ActiveWorkbook.Close
S1.ShowAllData
End If
Next
S1.Range("A5:AJ" & S1.Cells(Rows.Count, "A").End(3).Row).ClearContents
Sheets("Veri").Cells.Clear
S1.Select
MsgBox "Ok"
End Sub

Böl butonu için hazırlanmış bir koddur. Excel dosyanızın bulunduğu klasör altına il klasörlerini oluşturup içerisine ilgili illerin excel dosyasını oluşturmaya yarar. Açılışınız da excel dosyanıza "Veri" isimli bir sayfa ekleyerek deneyiniz.

 

[Rainbows]

Option Explicit

Sub Klasöre_Göre_Ayır()
Dim S As Long, klasör, klasör_kontrol, veri
Dim yeni_klasör As String, il_klasör As String, S1 As Worksheet, son, ilk
Application.DisplayAlerts = False
Set S1 = Sheets("Sheet1")
Set klasör = CreateObject("Scripting.FileSystemObject")

S1.Range("AK:AK").ClearContents

'böl
For S = 5 To S1.Cells(Rows.Count, "B").End(3).Row
If S1.Cells(S, "AK") <> "Aktarıldı" Then
    il_klasör = ThisWorkbook.Path & "\" & S1.Cells(S, "B") & "\"
    veri = klasör.FolderExists(il_klasör)
  If veri <> True Then
        klasör.CreateFolder il_klasör
    End If
'Var olmayan klasörleri oluşturdu

'excel dosyası oluşturmak için

Sheets("Veri").Delete
Sheets.Add
ActiveSheet.Name = "Veri"
son = S1.Cells(Rows.Count, "B").End(3).Row
    S1.Range("$A$4:$F$" & son).AutoFilter Field:=2, Criteria1:="" & S1.Cells(S, "B") & ""
    ilk = S1.Cells(1, "B").End(4).Row
    S1.Range(S1.Cells(ilk, "AK"), S1.Cells(son, "AK")) = "Aktarıldı"
    S1.Range(S1.Cells(ilk, "A"), S1.Cells(son, "AH")).Copy
  
    With Sheets("Veri")
    .Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    .Copy
    End With
      
    ActiveWorkbook.SaveAs Filename:= _
        "" & il_klasör & Range("B2") & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
'Klasör içerisine excel dosyalarını kopyaladı
ActiveWorkbook.Close
S1.ShowAllData
End If
Next
MsgBox "Ok"
End Sub

Böl butonu için hazırlanmış bir koddur. Excel dosyanızın bulunduğu klasör altına il klasörlerini oluşturup içerisine ilgili illerin excel dosyasını oluşturmaya yarar. Açılışınız da excel dosyanıza "Veri" isimli bir sayfa ekleyerek deneyiniz.

desteginiz için teşekkür ederim. çok ayırma işlemi cok güzel olmuş. sadece ayırma işlemini 4.satırdan itibaren degil de 3.satırdan itibaren yapabilir miyiz? hücre bicimlendirmelerini oldugu gibi almamız mümkün müdür acaba?

bölünün excel dosyalarını kişiler doldurduktan sonra birleştirmek istiyorum.(bölme işleminden sonra tabloyu sıfırlaması lazım) ve birleştirdigim sayfada da sadece gri ile boyadıgım alanlarıda güncelle butonu ile parcaladıgım ilgili yerlerden girilen datayı cekmesini istiyorum. bu konuda yardımcı olabilir misiniz?

ilginiz için,tekrardan teşekkür ederim.

 

[usubaykan]

Kodu tekrar revize ettim kontrol ediniz.

 

[usubaykan]

Güncelle butonu aktif değildir.

 

[Rainbows]

Güncelle butonu aktif değildir.

tekrardan teşekkürler,

veri çek dedigim zaman her bir excel sayfası için "There is a large amount of information in the Clipboard" hatasını veriyor.


birde güncelle butonunu nasıl yapabilirim. sadece gri ile işaretledigim kolonları sıra numarasına göre ilgili yerlere cekebilirim.

 

[usubaykan]

Tekrar deneyin. Tüm butonlar aktif.

 

[Rainbows]

Tekrar deneyin. Tüm butonlar aktif.

ilginiz için çok teşekkürler.

 

[Rainbows]

Tekrar deneyin. Tüm butonlar aktif.

merhabalar,

sheet1 sayfasında bazı degişikler yaparak bazı bölümlere grouplandırma ekledim ve bazı kolonlara da validationlar ekledim bir de sheet1 sayfasında degişiklik yapıldıkca calışan bir makro ekledim.

bölme işlemi yaparken sheet1 sayfasını oldugu gibi bölebilir miyiz? yani grouplandırmalar da gelecek validationlar da makrolar da.

bu mümkün müdür ?

 

[Rainbows]

Selamlar,

Bu konuda ne yapabilirim.

 

[Rainbows]

merhabalar,

sheet1 sayfasında bazı degişikler yaparak bazı bölümlere grouplandırma ekledim ve bazı kolonlara da validationlar ekledim bir de sheet1 sayfasında degişiklik yapıldıkca calışan bir makro ekledim.

bölme işlemi yaparken sheet1 sayfasını oldugu gibi bölebilir miyiz? yani grouplandırmalar da gelecek validationlar da makrolar da.

bu mümkün müdür ?

Bu konuda yapacak birşey yok sanırım