Soru Excel dosyasında satır ve sütunların yerlerini değiştirecek makro

[mtncbk]

Merhaba üsdatlar. Elimde ekteki gibi bir yüzlerce aynı formatta dosya mevcut.
Yapmak istediğim şeyler;
1-Makro klasör içindeki tüm dosyalara uygulanacak.
2-A1 ile A10 arası satırlar silinecek.
3-F sütununun soluna boş bir sütun ekleyecek
4- Sütun eklendikten sonra; G1 Hücresini F2 hücresine taşıyacak. Aynı zamanda G2 hücresinin dolu hücreleri sayısınca F2 hücresi aşağıya doğru aynı içerik doldurulacak.
Ekte orjinal dosya ve yapmayı istediklerim yapıldıktan sonraki dosyalar mevcut. Şöyle bir sıkıntım var; bu hücrelerin taşınmasında sütunlarda bulunan verilerin hücre sayıları farklılık göstermekte. Kiminde 20 hücre dolu iken kiminde 150 hücre dolu olabiliyor. Buna göre dolu hücrelerin taşımasını yapması lazım. Aynı zamanda sağ tarafta eğer veri var ise aynı şekilde hepsi bitene kadar taşıma yapması lazım. Database için veri hazırlamam lazım olduğu için çok ihtiyacım var. Şimdiden teşekkürlerimi sunuyorum. Saygılarımla.

 

[ÖmerBey]

Merhaba,
Klasörünüzün yedeğini aldıktan sonra aşağıdaki kodu çalıştırınız.
Kırmızı satırdaki klasör yolunu kendinizinki ile değiştiriniz.

Sub kod()
Dim w1 As Workbook
Dim s1 As Worksheet, s2 As Worksheet
Dim sat As Range, sut As Range
Dim klsr As String, dsy As String
Dim a As Byte
Application.ScreenUpdating = False
klsr = "D:\Dosyalar\"
dsy = Dir(klsr & "*.xlsx")
Do Until dsy = ""
    Set w1 = Workbooks.Open(klsr & dsy)
    Set s1 = w1.Sheets(1)
    If s1.Range("F11") = "" Or s1.Range("B12") = "" Then GoTo 1
    ReDim dz(1 To 7, 1 To 1)
    dz(1, 1) = "Sıra No"
    dz(2, 1) = "İl Adı"
    dz(3, 1) = "İlçe Adı"
    dz(4, 1) = "Mahalle/Köy"
    dz(5, 1) = "Sandık No"
    dz(6, 1) = ""
    dz(7, 1) = ""
    For Each sut In s1.Range(s1.Range("F11"), s1.Range("F11").End(xlToRight))
        If sut <> "" Then
            For Each sat In s1.Range(s1.Range("B12"), s1.Range("B12").End(xlDown))
                If sat <> "" Then
                    ReDim Preserve dz(1 To 7, 1 To UBound(dz, 2) + 1)
                    For a = 1 To 5
                        dz(a, UBound(dz, 2)) = s1.Cells(sat.Row, a)
                    Next
                    dz(6, UBound(dz, 2)) = sut.Value
                    dz(7, UBound(dz, 2)) = s1.Cells(sat.Row, sut.Column).Value
                End If
            Next
        End If
    Next
    Set s2 = w1.Sheets.Add
    s2.Name = "Yeni"
    s2.Range("A1").Resize(UBound(dz, 2), UBound(dz)).Value = Application.Transpose(dz)
1
    w1.Close True
    dsy = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "İşlem tamam."
End Sub