100 satırlık sütunu 100. satırdan başlayarak geriye doğru ayrı ayrı kaydetmek

B

buurakengin

Katılım
18 Ekim 2021
Mesajlar
36
Excel Vers. ve Dili
Excel 2016- Türkçe
sayfanın adı: cari

Cari sayfasında bulunan 100 satırlık sütunu 100. satırdan başlayarak geriye doğru ayrı ayrı masaüstüne kayıt etmek istiyorum.
100. satır 2020 nin aralık ayıdır ve geriye doğru gitmektedir. Kayıt ettiğimiz excellerinde 1. sütundaki adıyla kaydedilmesini istiyorum.

Yardımcı olabilir misiniz?
 
tamer42

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,102
Excel Vers. ve Dili
Office 2013 İngilizce
Aşağıdaki kodu dener misiniz



Kod: 
Sub DosyaaKaydet()
Dim WB As Workbook
Dim NewBook As Workbook
Dim SH As Worksheet
Dim SHT As Worksheet
Dim i As Integer
Dim fileName As String
Dim desktopFolderPath As String


Set WB = ThisWorkbook
desktopFolderPath = CreateObject("WScript.Shell").specialfolders("Desktop")


Set SH = WB.Sheets("Cari")

For i = 100 To 1 Step -1

    If SH.Cells(1, i) <> "" Then
    fileName = SH.Cells(1, i)
   
        Set NewBook = Workbooks.Add
        Set SHT = NewBook.Sheets(1)
       
        SH.Columns(i).Copy SHT.Cells(1, 1)
       
        Application.CutCopyMode = False
       
         NewBook.SaveAs fileName:=desktopFolderPath & "\" & fileName & ".xlsx"
         NewBook.Close
       
        Set SHT = Nothing
        Set NewBook = Nothing
   
    End If

Next i

Set SH = Nothing
Set WB = Nothing
End Sub
 
B

buurakengin

Katılım
18 Ekim 2021
Mesajlar
36
Excel Vers. ve Dili
Excel 2016- Türkçe
emeğiniz için teşekkür ederim ama malesef istediğim olmadı. madde madde anlatayım.

1: sayfanın adı cari.
2: bu sayfada 235 sütun var toplamda.
3: örnek olarak 235. sütunu silip masa üstündeki Burak klasörüne EXCEL olarak kayıt etmek istiyorum.(her excelin ismi silinen sütunun 3. satırı olmasını istiyorum)
4: bu işlem 4. sütuna kadar aynı devam edecek ve baştan değil 235. sütundan geriye doğru gidecek.
 
Son düzenleme:
H

haliliyas

Katılım
2 Temmuz 2014
Mesajlar
185
Excel Vers. ve Dili
2021 Türkçe, 64bit
harici siteye örnek dosya ekleyip dosya üzerinde açıklayarak sormanız mümkün mü?
 
B

buurakengin

Katılım
18 Ekim 2021
Mesajlar
36
Excel Vers. ve Dili
Excel 2016- Türkçe
hocam olmadı malesef, tek bir sütun getiriyor bu kod. benim istediğim 235. satırı silince kalanlar hepsi(234. satıra kadar olan verilerin hepsi olması gerekiyor.) durması gerekiyor.
 
D

dost

Katılım
15 Mart 2005
Mesajlar
382
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

Benim yazdığım kod:

Cari sayfasındaki son sütundan geriye doğru döngüye gir
-yeni excel sayfası yarat, döngüdeki sütunu kopyala yeni excel kitabının ilk sayfasına yapıştır, Sütunun 3.hücresindeki değere göre excel kitabına isim ver ve kaydet
Bu işlem 4.sütuna kadar devam eder.

Cari sayfasındaki 4.sütun ile son sütun arası sütunların tamamı sil.

Bu kadar.

EDIT: Yaratılan excel dosyalarından aynı isimli excel dosyası var mı kontrolü ilave edildi.

C++: 
Sub ws_Create()
   
    Dim sh1 As Worksheet
    Dim nWB As Workbook
    Dim myFolder As String, myFile As String, fName As String, tmpName As String
    Dim lColumn As Integer, c As Integer, iCount As Integer

    Application.ScreenUpdating = False

    myFolder = "C:\Users\" & Environ("UserName") & "\Desktop\BURAK"

    If VBA.Len(Dir(myFolder, vbDirectory)) = 0 Then
        MkDir myFolder
    End If

    On Error Resume Next
    Kill myFolder & "\*.xls?"
    On Error GoTo 0

    Set sh1 = ThisWorkbook.Sheets("Cari")

    lColumn = sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column

    If lColumn < 4 Then Exit Sub   
   
   For c = lColumn To 4 Step -1
        If Cells(3, c) <> "" Then
            fName = Cells(3, c)
            tmpName = fName
            sh1.Columns(c).Copy
           
            iCount = 0
            Do While Dir(myFolder & "\" & fName & ".xlsx") <> ""
                iCount = iCount + 1
                fName = tmpName & iCount
            Loop
           
            Set nWB = Workbooks.Add
            With nWB
                .Sheets(1).Paste
                .SaveAs fileName:=myFolder & "\" & fName & ".xlsx", FileFormat:=51
                .Close True
            End With
           
        End If
    Next c

    sh1.Range(sh1.Cells(1, 4), sh1.Cells(1, lColumn)).EntireColumn.Delete

    Set sh1 = Nothing:    Set nWB = Nothing

    MsgBox "İşlem tamamlandı ..."

    Application.ScreenUpdating = True

End Sub
 
Son düzenleme:
D

dost

Katılım
15 Mart 2005
Mesajlar
382
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

Yukarıdaki kod ile her seferinde yeni excel çalışma kitabını açıp kaydedildiğinden tamamlanması sütun sayısına göre biraz zaman alabilir.

Bunun yerine aşağıdaki kod ile hızlı sonuç alabilirsiniz.

C++: 
Sub ws_Create_ADO()
    Dim adoCN As Object, RS As Object
    Dim sh1 As Worksheet
    Dim myFolder As String, fName As String, tmpFile As String, colLatter As String
    Dim lColumn As Integer, i As Integer, iCount As Integer
 
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    myFolder = "C:\Users\" & Environ("UserName") & "\Desktop\BURAK"
    
    Set adoCN = VBA.CreateObject("ADODB.Connection")
    Set RS = VBA.CreateObject("ADODB.Recordset")

    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=Yes; IMEX=0"
    adoCN.Open
    
    myFolder = "C:\Users\" & Environ("UserName") & "\Desktop\BURAK"

    If VBA.Len(Dir(myFolder, vbDirectory)) = 0 Then
        MkDir myFolder
    End If

    On Error Resume Next
    Kill myFolder & "\*.xls?"
    On Error GoTo 0

    Set sh1 = ThisWorkbook.Sheets("Cari")

    lColumn = sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column
    lRow = sh1.UsedRange.Rows(sh1.UsedRange.Rows.Count).Row

    If lColumn < 4 Then Exit Sub

    colLatter = Split(sh1.Cells(1, lColumn).Address, "$")(1)
    
    strSQL = "Select * From [Cari$D1:" & colLatter & "] "

    Set RS = VBA.CreateObject("ADODB.Recordset")

    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN

    RS.MoveNext
    
    For i = 0 To RS.Fields.Count - 1
        fName = RS(i)
        tmpFile = RS(i)
        iCount = 0
        Do While Dir(myFolder & "\" & fName & ".xlsx") <> ""
            iCount = iCount + 1
            fName = tmpFile & iCount
        Loop
        CreateFileInDirectory myFolder, fName, RS(i).Name
    Next i
    
    sh1.Range(sh1.Cells(1, 4), sh1.Cells(lRow, lColumn)).ClearContents

    Set sh1 = Nothing:    Set adoCN = Nothing:    Set RS = Nothing

    Application.ScreenUpdating = True
    
    MsgBox "İşlem tamam..." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation, "SONUÇ"

    Exit Sub
    
ErrHandler:
        MsgBox Err.Description & " - " & Err.Number

End Sub

Sub CreateFileInDirectory(targetFolder As String, targetFile As Variant, targetFileld As String)
    Dim Conn As Object, objRS As Object
    Dim conStr As String, iSQL As String
    
    On Error GoTo ErrHandler
    
    Set Conn = VBA.CreateObject("ADODB.Connection")
    Set objRS = VBA.CreateObject("ADODB.Recordset")
    
    conStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & targetFolder & "\" & targetFile & ".xlsx" & _
            "; Extended Properties='Excel 12.0 Xml;HDR=YES';"
    
    Conn.Open conStr
    
    On Error Resume Next
    iSQL = "Create Table newTable (" & targetFileld & "  Varchar(50)) "
            
    objRS.Open iSQL, Conn, adOpenStatic, adLockOptimistic, adCmdText
    
    On Error GoTo ErrHandler
      
    iSQL = "Insert Into [newTable$] ([" & targetFileld & "]) " & _
                "Select  [" & targetFileld & "] From [Cari$] " & _
                "In '' [Excel 12.0;Database=" & ThisWorkbook.FullName & "] "
    
    objRS.Open iSQL, Conn, adOpenStatic, adLockOptimistic, adCmdText

    Conn.Close

Exit Sub
ErrHandler:
    If Err.Number = -2147217900 Then
        MsgBox "Yaratmak istediğiniz " & targetFile & " isimli excel dosyası " & Chr(10) & Chr(10) & _
                    targetFolder & Chr(10) & "Klasöründe mevcut !!!", vbCritical, "HATA"
    Else
        MsgBox Err.Description & " - " & Err.Number:
    End If

End Sub
 
B

buurakengin

Katılım
18 Ekim 2021
Mesajlar
36
Excel Vers. ve Dili
Excel 2016- Türkçe
dost' Alıntı:
Merhaba,

Yukarıdaki kod ile her seferinde yeni excel çalışma kitabını açıp kaydedildiğinden tamamlanması sütun sayısına göre biraz zaman alabilir.

Bunun yerine aşağıdaki kod ile hızlı sonuç alabilirsiniz.

C++: 
Sub ws_Create_ADO()
    Dim adoCN As Object, RS As Object
    Dim sh1 As Worksheet
    Dim myFolder As String, fName As String, tmpFile As String, colLatter As String
    Dim lColumn As Integer, i As Integer, iCount As Integer

    Application.ScreenUpdating = False
 
    Zaman = Timer
 
    myFolder = "C:\Users\" & Environ("UserName") & "\Desktop\BURAK"
 
    Set adoCN = VBA.CreateObject("ADODB.Connection")
    Set RS = VBA.CreateObject("ADODB.Recordset")

    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=Yes; IMEX=0"
    adoCN.Open
 
    myFolder = "C:\Users\" & Environ("UserName") & "\Desktop\BURAK"

    If VBA.Len(Dir(myFolder, vbDirectory)) = 0 Then
        MkDir myFolder
    End If

    On Error Resume Next
    Kill myFolder & "\*.xls?"
    On Error GoTo 0

    Set sh1 = ThisWorkbook.Sheets("Cari")

    lColumn = sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column
    lRow = sh1.UsedRange.Rows(sh1.UsedRange.Rows.Count).Row

    If lColumn < 4 Then Exit Sub

    colLatter = Split(sh1.Cells(1, lColumn).Address, "$")(1)
 
    strSQL = "Select * From [Cari$D1:" & colLatter & "] "

    Set RS = VBA.CreateObject("ADODB.Recordset")

    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN

    RS.MoveNext
 
    For i = 0 To RS.Fields.Count - 1
        fName = RS(i)
        tmpFile = RS(i)
        iCount = 0
        Do While Dir(myFolder & "\" & fName & ".xlsx") <> ""
            iCount = iCount + 1
            fName = tmpFile & iCount
        Loop
        CreateFileInDirectory myFolder, fName, RS(i).Name
    Next i
 
    sh1.Range(sh1.Cells(1, 4), sh1.Cells(lRow, lColumn)).ClearContents

    Set sh1 = Nothing:    Set adoCN = Nothing:    Set RS = Nothing

    Application.ScreenUpdating = True
 
    MsgBox "İşlem tamam..." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation, "SONUÇ"

    Exit Sub
 
ErrHandler:
        MsgBox Err.Description & " - " & Err.Number

End Sub

Sub CreateFileInDirectory(targetFolder As String, targetFile As Variant, targetFileld As String)
    Dim Conn As Object, objRS As Object
    Dim conStr As String, iSQL As String
 
    On Error GoTo ErrHandler
 
    Set Conn = VBA.CreateObject("ADODB.Connection")
    Set objRS = VBA.CreateObject("ADODB.Recordset")
 
    conStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & targetFolder & "\" & targetFile & ".xlsx" & _
            "; Extended Properties='Excel 12.0 Xml;HDR=YES';"
 
    Conn.Open conStr
 
    On Error Resume Next
    iSQL = "Create Table newTable (" & targetFileld & "  Varchar(50)) "
         
    objRS.Open iSQL, Conn, adOpenStatic, adLockOptimistic, adCmdText
 
    On Error GoTo ErrHandler
   
    iSQL = "Insert Into [newTable$] ([" & targetFileld & "]) " & _
                "Select  [" & targetFileld & "] From [Cari$] " & _
                "In '' [Excel 12.0;Database=" & ThisWorkbook.FullName & "] "
 
    objRS.Open iSQL, Conn, adOpenStatic, adLockOptimistic, adCmdText

    Conn.Close

Exit Sub
ErrHandler:
    If Err.Number = -2147217900 Then
        MsgBox "Yaratmak istediğiniz " & targetFile & " isimli excel dosyası " & Chr(10) & Chr(10) & _
                    targetFolder & Chr(10) & "Klasöründe mevcut !!!", vbCritical, "HATA"
    Else
        MsgBox Err.Description & " - " & Err.Number:
    End If

End Sub
Genişletmek için tıkla ...
Hocam eline sağlık kod çalıştı.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Üst