Dosya numarası ekleme

[nur_u_allah]

Arkadaşlar gönderdiğim örnek excelde yapmak istediğimi anlattım yardımcı olursanız sevınırım

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub DOSYA_NO_EKLE()
    Dim Hücre1 As Range, Hücre2 As Range, Dosya_No As Integer
    Dim İlk_Ayraç As Byte, Son_Ayraç As Byte
    Columns("A:A").Insert Shift:=xlToRight
    
    For Each Hücre1 In Columns("B:B").SpecialCells(xlCellTypeConstants, 23)
        If InStr(1, Hücre1.Value, "Dosya No") > 0 Then
        İlk_Ayraç = InStr(1, Hücre1.Value, ":") + 1
        Son_Ayraç = Len(Hücre1.Value) - InStr(1, Hücre1.Value, ":")
        Dosya_No = Mid(Replace(Hücre1.Value, ".", ","), İlk_Ayraç, Son_Ayraç)
    
    For Each Hücre2 In Range("B" & Hücre1.Row, "B" & Cells(Hücre1.Row, 2).End(4).Row)
        Cells(Hücre2.Row, 1) = Dosya_No
    Next
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[nur_u_allah]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub DOSYA_NO_EKLE()
    Dim Hücre1 As Range, Hücre2 As Range, Dosya_No As Integer
    Dim İlk_Ayraç As Byte, Son_Ayraç As Byte
    Columns("A:A").Insert Shift:=xlToRight
    
    For Each Hücre1 In Columns("B:B").SpecialCells(xlCellTypeConstants, 23)
        If InStr(1, Hücre1.Value, "Dosya No") > 0 Then
        İlk_Ayraç = InStr(1, Hücre1.Value, ":") + 1
        Son_Ayraç = Len(Hücre1.Value) - InStr(1, Hücre1.Value, ":")
        Dosya_No = Mid(Replace(Hücre1.Value, ".", ","), İlk_Ayraç, Son_Ayraç)
    
    For Each Hücre2 In Range("B" & Hücre1.Row, "B" & Cells(Hücre1.Row, 2).End(4).Row)
        Cells(Hücre2.Row, 1) = Dosya_No
    Next
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam ilgin için teşekkürler çok güzel oldu bi şi daha rica etsem bu ornektı bunun gıbı bissürü excel olarak rapor almaktayız
Bunu ayrı bı excel olarak ayarlayıpta ondan seçip istediğimize ekleme yaptıracak şekilde yapabilirmiyiz

 

[Korhan Ayhan]

Selamlar,

Genel bir ayarlama yapabilmek için veri yapılarınızı bilmek gerekir. Diğer excel dosyalarınızın hepsi aynı formatta mı? Ayrıca bu işlemi yapmak için nasıl bir yapı kullanmayı düşünüyorsunuz?

 

[nur_u_allah]

Diğer excel dosyaların yapıları aynı ben kodu ötekılerınde denedım her hangı bır sorun vermıyor ekleme yapıyor.
Benım ıstedıgım su sekılde ornek vereyım;Dosya aç komutu gıbı o raporu gosterecegım dosya numaralarını ekleyecek
Bu sekılde kodu her rapora eklemek lazım

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub SEÇİLEN_DOSYAYA_DOSYA_NO_EKLE()
    Dim Dosya As Variant, Kaynak_Dosya As Workbook
    Dim Hücre1 As Range, Hücre2 As Range, Dosya_No As Integer
    Dim İlk_Ayraç As Byte, Son_Ayraç As Byte
 
    Dosya = Application.GetOpenFilename("Excel Dosyası (*.xls),*.xls", , "Excel Dosyasını Seçin")
    If Dosya = False Then
    MsgBox "İşleme devam edebilmek için lütfen bir excel dosyası seçiniz !", vbExclamation, "Dikkat !"
    Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
    With Kaynak_Dosya.Sheets(1)
    
    .Columns("A:A").Insert Shift:=xlToRight
    
    For Each Hücre1 In .Columns("B:B").SpecialCells(xlCellTypeConstants, 23)
        If InStr(1, Hücre1.Value, "Dosya No") > 0 Then
        İlk_Ayraç = InStr(1, Hücre1.Value, ":") + 1
        Son_Ayraç = Len(Hücre1.Value) - InStr(1, Hücre1.Value, ":")
        Dosya_No = Mid(Replace(Hücre1.Value, ".", ","), İlk_Ayraç, Son_Ayraç)
    
            For Each Hücre2 In .Range("B" & Hücre1.Row, "B" & Cells(Hücre1.Row, 2).End(4).Row)
                .Cells(Hücre2.Row, 1) = Dosya_No
            Next
        End If
    Next
    Kaynak_Dosya.Close True
    
    End With
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[nur_u_allah]

Hocam tam istediğim gibi oldu saolun

 

[nur_u_allah]

Hocam bişi daha isteye bilirmiyim alt taraflarda dosya numaraları eklendıkten sonra grı ıle ayrılan satırları sıldırebılırmıyız
Yanı grı ile ayrım yapılan alanları çalışma sayfasının en ust tarafındakı alan kalacak

 

[nur_u_allah]

Hocam cevabınızı beklıyoruz

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub SEÇİLEN_DOSYAYA_DOSYA_NO_EKLE()
    Dim Dosya As Variant, Kaynak_Dosya As Workbook
    Dim Hücre1 As Range, Hücre2 As Range, X As Long, Dosya_No As Integer
    Dim İlk_Ayraç As Byte, Son_Ayraç As Byte
 
    Dosya = Application.GetOpenFilename("Excel Dosyası (*.xls),*.xls", , "Excel Dosyasını Seçin")
    If Dosya = False Then
    MsgBox "İşleme devam edebilmek için lütfen bir excel dosyası seçiniz !", vbExclamation, "Dikkat !"
    Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
    With Kaynak_Dosya.Sheets(1)
    
    .Columns("A:A").Insert Shift:=xlToRight
    
    For Each Hücre1 In .Columns("B:B").SpecialCells(xlCellTypeConstants, 23)
        If InStr(1, Hücre1.Value, "Dosya No") > 0 Then
        İlk_Ayraç = InStr(1, Hücre1.Value, ":") + 1
        Son_Ayraç = Len(Hücre1.Value) - InStr(1, Hücre1.Value, ":")
        Dosya_No = Mid(Replace(Hücre1.Value, ".", ","), İlk_Ayraç, Son_Ayraç)
    
            For Each Hücre2 In .Range("B" & Hücre1.Row, "B" & Cells(Hücre1.Row, 2).End(4).Row)
                .Cells(Hücre2.Row, 1) = Dosya_No
            Next
        End If
    Next
    
    For X = 5 To 1 Step -1
        If .Cells(X, 2).Interior.ColorIndex = 15 And InStr(1, .Cells(X, 2), "Sıra No") = 0 Then .Rows(X).EntireRow.Delete
    Next
    
    For X = .Range("B65536").End(3).Row To 3 Step -1
        If .Cells(X, 2).Interior.ColorIndex = 15 Then .Rows(X).EntireRow.Delete
    Next
    
    Kaynak_Dosya.Close True
    
    End With
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[nur_u_allah]

Hocam üst taraftaki SIRA NO ABONE NO satırının kalması lazım.Ama 1-2-3 satırında sılınmesı lazım ben bı ayarlama yaptım sıra no ve abone no yu bıraktım ama 1-2-3 satırı sıle bılırmıyız gayet guzel oldu su an bıde onları halletsek size zahmet saygılarımla

 

[Korhan Ayhan]

Selamlar,

Bahsettiklerinizi örnek dosya üzerinde açıklarmısınız.

 

[nur_u_allah]

Hocam ekta anlattım kusura bakmayın unuttum bu sekılde anlatmayı

 

[Korhan Ayhan]

Selamlar,

#10 nolu mesajımdaki kodu güncelledim. Denermisiniz.

 

[nur_u_allah]

Hocam son bi ayrınTI en ustte dosya no satırı kalıyor yine onuda sildire bilirmiyiz
Benim hatam açıklamaya eklemeyi unutmusum

 

[nur_u_allah]

Hocam hata vermeye başladı nedendır anlamadım
Adsız olarak resımıde ekledım

 

[Korhan Ayhan]

Selamlar,

#10 nolu mesajımdaki kodu güncelledim. Denermisiniz.

 

[nur_u_allah]

Hocam ekledıgım dosyayaya bı bakarmısınız

 

[Korhan Ayhan]

Selamlar,

#10 nolu mesajımdaki kodu güncelledim. Denermisiniz.

 

[nur_u_allah]

Hocam tamamdır emeklerınız ıcın çok tesekkur ederım