yaklaşık 10.000 farklı excelin içeriğinde yer değiştirme

[kakara]

Merhaba ustadlarım sorunumu ektekı dosyada detaylı anlatmaya calıstım yaklasık on bın farklı ısımde excel var eger rıcamın çözümü varsa benı çok buyuk bır yukten kurataracak ılgınız ıcın sımdıden tesekkurler

 

[Korhan Ayhan]

Merhaba,

Bahsettiğiniz sarı alan "GENEL KRİTİKLER" alanına aktarılabilir. Fakat bu sarı alanın tespiti için parametrik bir bilgi gerekli. Yani bu alan dosyalrda neye göre yakalanacak/bulunacak? Bu parametre önem arz ediyor.

 

[kakara]

@Korhan Ayhan ustadım sıze verebılecegım tek parametrık alan beden numaraların altında ölçulerın oldugu yer olabılır yanı o alanı yakalamak ıcın beden bıttıkten sonrakı ılk veya ondan sonrakı sutunun ıcınde yazılmıstır. eklı dosyamda daha detaylı anlatmaya calıstım ılgınız ıcın sımdıden tesekkurler.

 

[Korhan Ayhan]

O zaman şöyle yapalım..

Siz en az 5 adet farklı yapıda olan dosya paylaşın. Onların üzerinden sonuç üretmeye çalışalım.

 

[kakara]

@Korhan Ayhan ustadım ılgınız ıcın öncelıkle tesekkur ederım farklı sekılde beş dosya paylaştım. eger olabılitesi varsa a-e sutunları arasında da acıklamalar var ( sarı ıle boyadım ) onlarıda '' genel krıtıkler '' ın en altına alabılır mıyız ? ılgınız ıcın tekrar tesekkur ederım.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kod paylaştığınız 2 dosya dışında sonuç üretti.

"COCUK" ve "ERKEK ÇOCUK" dosyalarında "GENEL KRİTİKLER" satırını bulamadığı için sonuç üretmedi. Bulmaması için bir sebep göremedim.

Sizde deneyin. Belki sizde tümünde çalışır. Eğer çalışmazsa farklı bir kod deneriz.

Kod içindeki My_Path = "C:\Users\Test\" klasör yolunu kendinize göre düzenlersiniz.

Option Explicit

Sub Edit_Files()
    Dim My_Path As String, My_File As String, Find_Text As Range
    Dim WB As Workbook, WS As Worksheet, First_Row As Long
    Dim Last_Cell As Range, Body_Last_Column As Integer
    Dim First_Cell As Range, Table_Last_Cell As Range
    Dim First_Adress As String, Last_Adress As String
   
    Application.ScreenUpdating = False
   
    My_Path = "C:\Users\Test\"
   
    My_File = Dir(My_Path & "*.xls*")
   
    While My_File <> ""
        If My_File <> ThisWorkbook.Name Then
            Set WB = Workbooks.Open(My_Path & My_File, False, False)
            Set WS = WB.Sheets("ÖLÇÜ TABLOSU")
            Set Find_Text = WS.Cells.Find(What:="GENEL KRİTİKLER", After:=WS.Cells(1), LookIn:=xlValues, LookAt:=xlPart)
            If Not Find_Text Is Nothing Then
                First_Row = WS.Cells(1, "A").End(4).Row
                WS.Range("A" & First_Row & ":E" & Find_Text.Row - 1).Cut WS.Cells(WS.Rows.Count, 1).End(3)(2, 1)
               
                Set Last_Cell = WS.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
                If Not Last_Cell Is Nothing Then
                    Body_Last_Column = WS.Cells(2, WS.Columns.Count).End(1).Offset(, 1).Column
                    Set First_Cell = WS.Cells(2, Body_Last_Column).Resize(Find_Text.Row - 1, 5).Find("*", LookIn:=xlValues)
                    If Not First_Cell Is Nothing Then
                        Set Table_Last_Cell = WS.Cells.SpecialCells(xlCellTypeLastCell)
                        First_Adress = WS.Cells(First_Cell.Row, Body_Last_Column).Address
                        Last_Adress = WS.Cells(Find_Text.Row - 1, Table_Last_Cell.Column).Address
                        WS.Range(First_Adress & ":" & Last_Adress).Cut WS.Cells(WS.Rows.Count, 1).End(3)(2, 1)
                    End If
                End If
            End If
            WB.Close True
        End If
       
        My_File = Dir
    Wend
   
    Set Last_Cell = Nothing
    Set First_Cell = Nothing
    Set Table_Last_Cell = Nothing
    Set Find_Text = Nothing
    Set WB = Nothing
    Set WS = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Bu da bahsettiğim alternatif kodlamadır. Bu daha sağlıklı sonuç veriyor.

Üstte paylaştığım kod CTRL+F ile "GENEL KRİTİKLER" satırını bularak işlem yapıyordu. Ama dediğim gibi paylaştığınız iki dosyada sorun çıkardı. Aşağıdaki kod ise "GENEL KRİTİKLER" satırını döngü ile buluyor (A-AZ sütun aralığına bakıyor) ve işlem yapıyor.

Option Explicit

Sub Edit_Files()
    Dim My_Path As String, My_File As String
    Dim WB As Workbook, WS As Worksheet, First_Row As Long
    Dim Last_Cell As Range, Body_Last_Column As Integer
    Dim First_Cell As Range, Table_Last_Cell As Range
    Dim First_Adress As String, Last_Adress As String
    Dim X As Long, Find_Text_Row As Long
  
    Application.ScreenUpdating = False
  
    My_Path = "C:\Users\Test\"
  
    My_File = Dir(My_Path & "*.xls*")
  
    While My_File <> ""
        If My_File <> ThisWorkbook.Name Then
            Set WB = Workbooks.Open(My_Path & My_File, False, False)
            Set WS = WB.Sheets("ÖLÇÜ TABLOSU")
          
            For X = WS.Cells(WS.Rows.Count, 1).End(3).Row To 1 Step -1
                For Y = 1 To 52
                    If WS.Cells(X, Y) = "GENEL KRİTİKLER" Then
                        Find_Text_Row = X
                        Exit For
                    End If
                Next
            Next
          
            First_Row = WS.Cells(1, "A").End(4).Row
            WS.Range("A" & First_Row & ":E" & Find_Text_Row - 1).Cut WS.Cells(WS.Rows.Count, 1).End(3)(2, 1)
          
            Set Last_Cell = WS.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            If Not Last_Cell Is Nothing Then
                Body_Last_Column = WS.Cells(2, WS.Columns.Count).End(1).Offset(, 1).Column
                Set First_Cell = WS.Cells(2, Body_Last_Column).Resize(Find_Text_Row - 1, 5).Find("*", LookIn:=xlValues)
                If Not First_Cell Is Nothing Then
                    Set Table_Last_Cell = WS.Cells.SpecialCells(xlCellTypeLastCell)
                    First_Adress = WS.Cells(First_Cell.Row, Body_Last_Column).Address
                    Last_Adress = WS.Cells(Find_Text_Row - 1, Table_Last_Cell.Column).Address
                    WS.Range(First_Adress & ":" & Last_Adress).Cut WS.Cells(WS.Rows.Count, 1).End(3)(2, 1)
                End If
            End If
          
            WB.Close True
        End If
      
        My_File = Dir
    Wend
  
    Set Last_Cell = Nothing
    Set First_Cell = Nothing
    Set Table_Last_Cell = Nothing
    Set Find_Text = Nothing
    Set WB = Nothing
    Set WS = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kakara]

@Korhan Ayhan ustadım ılgınız ıcın tesekkur ederım dun bakamadım malesef bugun bakıp sızıde bılgılendırıcem.

 

[kakara]

@Korhan Ayhan ustadım alternatıf kodlamanız mukemmel calısıyor ılgınız ıcın tekrar tesekkur ederım .