- Katılım
- 8 Nisan 2013
- Mesajlar
- 16
- Excel Vers. ve Dili
-
Office 16 En
Office 365 En
64-bit
- Altın Üyelik Bitiş Tarihi
- 01-03-2023
Merhaba,
Aşağıdaki kodları forumdan bulup kendime göre derledim.
Fakat, ekli dosyada da görüleceği üzere ölçü başlıkları en son satırda çıkıyor.
Ben ise üçüncü satırda sabit ve başlık olarak kalmasını istiyorum.
Tüm denemelerime rağmen bir türlü beceremedim.
Yardımlarınız için şimdiden teşekkürler.
Aşağıdaki kodları forumdan bulup kendime göre derledim.
Fakat, ekli dosyada da görüleceği üzere ölçü başlıkları en son satırda çıkıyor.
Ben ise üçüncü satırda sabit ve başlık olarak kalmasını istiyorum.
Tüm denemelerime rağmen bir türlü beceremedim.
Yardımlarınız için şimdiden teşekkürler.
Kod:
Dim sat As String
Private Sub CommandButton1_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
[A2:I65000] = ""
sat = 4
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
If Right(yol, 1) <> "\" Then ekle = "\"
On Error Resume Next
For Each Dosya In fs
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
sayfaadi = "Form3"
deg = "'" & yol & ekle & "[" & Dosya.Name & "]" & sayfaadi & "'!R"
If ExecuteExcel4Macro(deg & 3 & "C" & 3) <> "" Then
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya.Name
Worksheets(ActiveSheet.Name).Cells(sat, "G") = ExecuteExcel4Macro(deg & 13 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "F") = ExecuteExcel4Macro(deg & 12 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "E") = ExecuteExcel4Macro(deg & 11 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "D") = ExecuteExcel4Macro(deg & 10 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "C") = ExecuteExcel4Macro(deg & 9 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "B") = ExecuteExcel4Macro(deg & 8 & "C" & 5)
sat = Cells(Rows.Count, "b").End(3).Row + 1
If ExecuteExcel4Macro(deg & 3 & "C" & 3) <> "" Then
Worksheets(ActiveSheet.Name).Cells(sat, "G") = ExecuteExcel4Macro(deg & 13 & "C" & 2)
Worksheets(ActiveSheet.Name).Cells(sat, "F") = ExecuteExcel4Macro(deg & 12 & "C" & 2)
Worksheets(ActiveSheet.Name).Cells(sat, "E") = ExecuteExcel4Macro(deg & 11 & "C" & 2)
Worksheets(ActiveSheet.Name).Cells(sat, "D") = ExecuteExcel4Macro(deg & 10 & "C" & 2)
Worksheets(ActiveSheet.Name).Cells(sat, "C") = ExecuteExcel4Macro(deg & 9 & "C" & 2)
Worksheets(ActiveSheet.Name).Cells(sat, "B") = ExecuteExcel4Macro(deg & 8 & "C" & 2)
End If
End If
End If
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
Benim makro ile ilişkim çok fazla olmadığı için benzer bir format bulup üzerinden uyarlamaya çalışıyorum.