Çalışma Sayfasına Sütun Ekleme (topluca)

[sonageldik]

Elimdeki yüzlerce aynı tipte çalışma kitabı var. Bu çalışma kitaplarını bir klasöre koyduktan sonra topluca yani bir defada çalışma kitaplarının başına 2 adet sütun eklemek istiyorum. Birinci Sütunun başında DURUMU, ikinci sütunun başında ise SAYISI yazmasını nasıl sağlayabiliriz.

Saygılarımla..

Sarı ile işaretli sütunların olduğu kısım gibi.

tekrar teşekkürler

 

[Korhan Ayhan]

Deneyiniz..

Option Explicit
 
Sub DOSYALARDAKİ_SAYFALARA_İKİ_SÜTUN_EKLE()
    Dim K1 As Workbook, K2 As Workbook, Sayfa As Worksheet
    Dim X As Integer, Bul As Range, Son_Satır As Long
    Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
    
    If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
        Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
    ElseIf Not Klasör Is Nothing Then
        Kaynak_Klasör = Klasör.Items.Item.Path
    Else
        MsgBox "İşleme devam edebilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Dosya = Dir(Kaynak_Klasör & "\*.xl*")
    
    Do
        If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya", vbTextCompare) = 0 Then
            DoEvents
            Application.DisplayAlerts = False
            Set K2 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
            Application.DisplayAlerts = True
                        
            For Each Sayfa In K2.Worksheets
                With Sayfa
                    On Error Resume Next
                    If .AutoFilterMode Then .ShowAllData
                    Set Bul = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
                    On Error GoTo 0
                    If Not Bul Is Nothing Then Son_Satır = Bul.Row
                    If Son_Satır > 0 Then
                        .Range("A:B").Insert Shift:=xlToRight
                        .Range("A1:B" & Son_Satır).Borders.LineStyle = 1
                        .Range("A1:B1").Value = Array("DURUMU", "SAYISI")
                        Son_Satır = 0
                    End If
                End With
            Next
            
            K2.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
    
    Set K1 = Nothing
    Set K2 = Nothing
    
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[sonageldik]

Sorunsuz ve faydalı katkınız için teşekkür ederim. Allah razı olsun.