Farklı dosyalardaki verilerin yüzdesini hesaplama

[hadromer]

Merhaba,
S01 ile başlayıp S44 ile biten 44 farklı dosyam mevcut. bu dosyaların başlıkları sabit, değerler farklılık gösteriyor.
C sütunundaki veri ile J sütunundaki veriyi kopyalayıp boş bir sütuna yapıştırıp yanına yüzdesini hesaplayıp yüzde sütunu koymam gerekiyor. farklı bir sayfa olacak şekilde de yapabilirsiniz.
C sütununda 11,121 gibi kodlar var. bu kodlardan tekrar edenler var. bu değerlerin de toplanması gerekiyor.
örnek dosya içerisinde bir örnek mevcut. Rica etsem yardımcı olur musunuz ? teşekkür ederim.

Örnek Dosya : https://s2.dosya.tc/server18/qa2tmb/s01.xls.html

 

[ÖmerBey]

Merhaba,
Dosyalarınızın yedeğini aldıktan sonra yol değişkenini kendi dosyalarınızın olduğu klasör yolu ile değiştirerek aşağıdaki kodu boş bir dosyada çalıştırınız.

Sub kod()
Dim w1 As Workbook
Dim s1 As Worksheet, s2 As Worksheet
Dim yol As String, dsy As String
Dim a As Integer, b As Integer, x As Integer

Application.ScreenUpdating = False
yol = "C:\Dosyalarım\"

For a = 1 To 44
dsy = yol & "s" & Format(a, "00") & ".xls"
If Dir(dsy) <> "" Then
    Set w1 = Workbooks.Open(dsy)
    Set s1 = w1.Sheets("s" & Format(a, "00"))
    Set s2 = Sheets.Add(After:=s1)
    s2.Name = "Yuzde"
    x = 1
    s2.Cells(x, 1).Value = "Code_18"
    s2.Cells(x, 2).Value = "alan"
    s2.Cells(x, 3).Value = "Yüzde"
    For b = 2 To s1.Cells(s1.Rows.Count, 3).End(3).Row
        If WorksheetFunction.CountIf(s1.Range("C2:C" & b), s1.Cells(b, 3)) = 1 Then
            x = x + 1
            s2.Cells(x, 1).Value = s1.Cells(b, 3).Value
            s2.Cells(x, 2).Value = WorksheetFunction.SumIf(s1.Range("C:C"), s1.Cells(b, 3), s1.Range("J:J"))
        End If
    Next
    s2.Cells(x + 2, 1).Value = "Toplam"
    s2.Cells(x + 2, 2).Formula = "=SUM(B2:B" & x & ")"
    s2.Range("C2:C" & x).Formula = "=B2*100/B$" & x + 2
    Application.DisplayAlerts = False
    w1.Close 1
    Application.DisplayAlerts = True
End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

 

[hadromer]

Merhaba,
Dosyalarınızın yedeğini aldıktan sonra yol değişkenini kendi dosyalarınızın olduğu klasör yolu ile değiştirerek aşağıdaki kodu boş bir dosyada çalıştırınız.

Sub kod()
Dim w1 As Workbook
Dim s1 As Worksheet, s2 As Worksheet
Dim yol As String, dsy As String
Dim a As Integer, b As Integer, x As Integer

Application.ScreenUpdating = False
yol = "C:\Dosyalarım\"

For a = 1 To 44
dsy = yol & "s" & Format(a, "00") & ".xls"
If Dir(dsy) <> "" Then
    Set w1 = Workbooks.Open(dsy)
    Set s1 = w1.Sheets("s" & Format(a, "00"))
    Set s2 = Sheets.Add(After:=s1)
    s2.Name = "Yuzde"
    x = 1
    s2.Cells(x, 1).Value = "Code_18"
    s2.Cells(x, 2).Value = "alan"
    s2.Cells(x, 3).Value = "Yüzde"
    For b = 2 To s1.Cells(s1.Rows.Count, 3).End(3).Row
        If WorksheetFunction.CountIf(s1.Range("C2:C" & b), s1.Cells(b, 3)) = 1 Then
            x = x + 1
            s2.Cells(x, 1).Value = s1.Cells(b, 3).Value
            s2.Cells(x, 2).Value = WorksheetFunction.SumIf(s1.Range("C:C"), s1.Cells(b, 3), s1.Range("J:J"))
        End If
    Next
    s2.Cells(x + 2, 1).Value = "Toplam"
    s2.Cells(x + 2, 2).Formula = "=SUM(B2:B" & x & ")"
    s2.Range("C2:C" & x).Formula = "=B2*100/B$" & x + 2
    Application.DisplayAlerts = False
    w1.Close 1
    Application.DisplayAlerts = True
End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

teşekkür ederim, istediğim gibi çalıştı.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...