Birleştirilmiş verilerin parçalandıktan sonra sayılması

Tevfik_Kursun · 19 Aralık 2017

Merhaba Arkadaşlar,
27 öğrencinin numarası, sınıfı ve cinsiyeti aynı hücrede birleştirilmiştir.
PARÇAAL fonksiyonu ile parçalanıyor. Her parçadan sınıflar çekiliyor. (E sütununda)
Yinelenmiş sınıflar kaldırılıyor. (G sütununda) (bunu makro ile yapabiliyorum)
I, J ve K sütunlarında sınıflara göre sayım yapılıyor.
Bu işlemler makro ile nasıl yapılır?
Saygılarımla

askm · 19 Aralık 2017

Tevfik Bey anladığım kadarıyla son karakter cinsiyet. Siz cinsiyet sayısını almak istiyorsanız sadece son karakteri saymanız yeterli olmaz mı? Son karakterdeki E ve K harflerini saymanız yeterli sanırım.

Tevfik_Kursun · 20 Aralık 2017

Merhaba Sayın Arkadaşım,
Haklısınız aslında, ama ben fonksiyondan makroya geçmeye çalışıyorum. Sayın Asri Hocanın desteği ile fonksiyonla 8 Mb ın üzerine çıkmış dosyayı 1,1 Mb a düşürüp hızlı çalışmasını sağladım. Dosya son derece hantaldı, şimdi rapor dönemi geldi baktım yine ağırlaşıyor.

Kod:

Sub Parcaal_2()
    For i = 1 To 27
        Cells(7 + i, 5) = Mid(Cells(7 + i, 3), (i - 1) * 11 + 7, 4)
    Next i
End Sub

C sütununu yaptım. Şimdi E sütunundayım. Bu makro sadece 1. değeri veriyor, sonrası gelmiyor. G sütununu yaptım. Sonra da saymayı öğreneceğim.
İlginize teşekkür ederim.
Saygılarımla

askm · 20 Aralık 2017

Olması gereken halini sayfa2 ye yazarsanız kod yazmaya çalışalım.

Tevfik_Kursun · 20 Aralık 2017

Merhaba,
Olması gereken zaten bu sayfada her şeyiyle. E sütunu hizasındakinden sınıf alacak. G tamam, sadece I sütunu olsa bitti.
Saygılarımla

askm · 20 Aralık 2017

Sanırım şu kod üçü için de işinizi görür.

Kod:

Sub ASKM_Say()
Dim Son As Long
Son = Range("G" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 8 To Son
    SayT = WorksheetFunction.CountIf(Range("C8:C34"), "*" & Cells(i, 7) & "?")
    SayK = WorksheetFunction.CountIf(Range("C8:C34"), "*" & Cells(i, 7) & "K")
    SayE = WorksheetFunction.CountIf(Range("C8:C34"), "*" & Cells(i, 7) & "E")
    Cells(i, 9) = SayT
    Cells(i, 10) = SayK
    Cells(i, 11) = SayE
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

Tevfik_Kursun · 20 Aralık 2017

Sayın Hocam,
İlginize çok teşekkür ederim. Hemen deneyeceğim.
3. mesajda benim yazdığım makro sadece E8 hücresini dolduruyor, diğerleri boş. Neden olabilir?
Saygılarımla

Tevfik_Kursun · 20 Aralık 2017

Merhaba Sayın Hocam,
Makro çok güzel çalıştı. E sütununu da halledebilirsem, şahane olur. İlginize çok teşekkür ederim.
Saygılarımla

Asri · 20 Aralık 2017

ALternatif;

Kolaya kaçtım

Makro sadece C sütünunu dikkate alır. G,I,J,K yı kendisi oluşturur. E yi oluşturmaz.

Kod:

Sub parcala_say()
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
    Sheets("Sayfa1").Select
    Range("G8:K10000").Clear
    
    If WorksheetExists("Gecicixxxxx") Then Sheets("Gecicixxxxx").Delete
    Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
    newsh.Name = "Gecicixxxxx"
    
    
    Sheets("Sayfa1").Select
    Range("B6").Select
    Selection.Copy
    Sheets("Gecicixxxxx").Select
    Range("B1").Select
    ActiveSheet.Paste
    Range("A5").Select
    
    veri = Range("B1").Value
    Satir = 1
    For i = 1 To Len(veri)
      Cells(Satir, "A").Value = Left(veri, 11)
      veri = Mid(veri, 12, Len(veri))
      Satir = Satir + 1
    Next i
    Cells(1, "B").Value = ""
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(10, 1)), TrailingMinusNumbers:= _
        True
    Sheets("Gecicixxxxx").Select
 
    Range("B1:C1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Sınıf"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Cinsiyet"
  
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:B").Select
    
    'Office 2016
'    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
'        "Gecicixxxxx!R1C1:R1048576C2", Version:=6).CreatePivotTable TableDestination _
'        :="Gecicixxxxx!R1C6", TableName:="OzetsinifTablosu", DefaultVersion:=5
        
    'Office 2010
    Columns("A:B").Select
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Gecicixxxxx!R1C1:R1048576C2", Version:=xlPivotTableVersion14). _
        CreatePivotTable TableDestination:="Gecicixxxxx!R2C6", TableName:= _
        "OzetsinifTablosu", DefaultVersion:=xlPivotTableVersion14
        
        
    Sheets("Gecicixxxxx").Select
    Cells(1, 6).Select
    With ActiveSheet.PivotTables("OzetsinifTablosu").PivotFields("Sınıf")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("OzetsinifTablosu").AddDataField ActiveSheet.PivotTables( _
        "OzetsinifTablosu").PivotFields("Cinsiyet"), "Say Cinsiyet", xlCount
    With ActiveSheet.PivotTables("OzetsinifTablosu").PivotFields("Cinsiyet")
        .Orientation = xlColumnField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("OzetsinifTablosu").PivotFields("Sınıf")
        .PivotItems("(blank)").Visible = False
    End With
    Columns("F:I").Select
    Selection.Copy
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G8").Select
    Application.CutCopyMode = False
    
    
      Columns("A:E").Select
    Range("E1").Activate
    Selection.Delete Shift:=xlToLeft
    Rows("1:2").Select
    Selection.Delete Shift:=xlUp
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "T"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Sınıf"
    Columns("C:C").Select
    Selection.Cut Destination:=Columns("E:E")
    Columns("B:B").Select
    Selection.Cut Destination:=Columns("F:F")
    Columns("B:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
    Columns("B:D").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("B:B").Select
    Columns("B:B").EntireColumn.AutoFit
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("B:B").ColumnWidth = 1.57
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Rows(sonsatir).Delete
    Range("F8").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Range("A2:E" & sonsatir).Select
    Selection.Copy
    Sheets("Sayfa1").Select
    Range("G8").Select
    ActiveSheet.Paste
    Range("G8").Select
    If WorksheetExists("Gecicixxxxx") Then Sheets("Gecicixxxxx").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

Tevfik_Kursun · 20 Aralık 2017

Merhaba Asri Hocam,
Utanıyordum size sormaya. Yine Hızır gibi yetiştiniz. Hemen deneyeceğim. Çalışmam hemen hemen bitmek üzere. Umarım hazırladığımla sınıf geçerim.
İlginize teşekkür ederim
Saygılarımla

askm · 20 Aralık 2017

E için de ekleme yaptım.

Kod:

Sub ASKM_Say()
Dim Son As Long
Son = Range("G" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For x = 8 To 34
    Cells(x, 5) = Mid(Cells(x, 3), 7, 4)
Next x
    
For i = 8 To Son
    SayT = WorksheetFunction.CountIf(Range("C8:C34"), "*" & Cells(i, 7) & "?")
    SayK = WorksheetFunction.CountIf(Range("C8:C34"), "*" & Cells(i, 7) & "K")
    SayE = WorksheetFunction.CountIf(Range("C8:C34"), "*" & Cells(i, 7) & "E")
    Cells(i, 9) = SayT
    Cells(i, 10) = SayK
    Cells(i, 11) = SayE
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

Asri · 20 Aralık 2017

Tevfik_Kursun' Alıntı:
Merhaba Asri Hocam,
Utanıyordum size sormaya. Yine Hızır gibi yetiştiniz. Hemen deneyeceğim. Çalışmam hemen hemen bitmek üzere. Umarım hazırladığımla sınıf geçerim.
İlginize teşekkür ederim
Saygılarımla

Estğ. Hocam, tesadüf denk geldim.
İşlemi başka sayfada excel in nimetleri ile çözüp sonucu asıl sayfaya yapıştırmak bu aralar bende tembellik yapmaya başladı

Tevfik_Kursun · 20 Aralık 2017

Merhaba Sayın Hocam,
Ekli resimdeki hatayı verdi
Saygılarımla

Tevfik_Kursun · 20 Aralık 2017

Sayın Askm Hocam,
İlginize çok teşekkür ederim. Hemen deneyeceğim.
Saygılarımla

Asri · 20 Aralık 2017

Tevfik_Kursun' Alıntı:
Merhaba Sayın Hocam,
Ekli resimdeki hatayı verdi
Saygılarımla

Office 2016 nın özet tablosu 2010 da sorun çıkardı sanırım.
2010 a göre yeniden hazırlandı. Test edildi.

Kod güncellendi.

Tevfik_Kursun · 20 Aralık 2017

Muhteşemsiniz Asri Hocam,
Çok teşekkür ederim. Kabul edin ki ben de iyi bir öğreniciyim.
Bu vesile ile http://www.excel.web.tr ailesine minnettar olduğumu belirtirim.
Saygılarımla

Asri · 20 Aralık 2017

Tevfik_Kursun' Alıntı:
Muhteşemsiniz Asri Hocam,
Çok teşekkür ederim. Kabul edin ki ben de iyi bir öğreniciyim.
Bu vesile ile http://www.excel.web.tr ailesine minnettar olduğumu belirtirim.
Saygılarımla

Hocam şimdi farkettim, aslında C yi dikkate almaya gerek yok.

Kodlar sadece B6 yı dikkate alacak şekilde yenilendi.

27 farklı sınıf için sonuçlar oluştu.
Sınıf bilgilerinin 11 karakter olması çok önemli. ne eksik ne fazla olmalı.

Hızlı öğreniyorsunuz kabul ediyorum

İyi geceler.

Tevfik_Kursun · 20 Aralık 2017

Tekrar Merhaba,
Hata var gibi geldi bana, ama hata yok çok teşekkür ederim
İyi geceler
Saygılarımla

antonio · 20 Aralık 2017

Merhaba,
Ben kodları yazarken cevaplar gelmiş zaten.
Alternatif olsun.
Örnek dosyanıza göre aşağıdaki kodları da deneyebilirsiniz.

Kod:

Sub sinif_analizi()
Dim sh As Worksheet, baz As String, i As Integer, uznl As Integer, _
    sayi As Integer, onbir As String, sat As Integer, snf As String, _
    ss As Long, x As Integer, z As Object, aranan As String, n As Integer, _
    s As Integer, siniflar As Range, erkek As Integer, kiz As Integer, _
    y As Integer, a As Integer, se As String, sk As String

Set z = CreateObject("scripting.dictionary")
    z.comparemode = vbTextCompare
    
n = 0
sat = 8
Set sh = Sayfa1
baz = sh.Range("B6").Value
uznl = Len(baz)
sayi = uznl / 11
For i = 1 To uznl Step 11
    onbir = Mid(baz, i, 11)
    sh.Range("C" & sat).Value = onbir
    snf = Mid(onbir, 7, 4)
    sh.Range("E" & sat).Value = snf
    sat = sat + 1
Next i

ss = sh.Range("E56789").End(3).Row
s = 7
For x = 8 To ss
    If sh.Range("E" & x) <> "" Then
        aranan = sh.Range("E" & x).Value
        If Not z.exists(aranan) Then
            n = n + 1
            s = s + 1
            z.Add aranan, n
            sh.Range("G" & s).Value = aranan
        End If
    End If
Next x
Set siniflar = sh.Range("C8:C" & ss)
y = 8
For a = 8 To s
    se = "*" & sh.Range("G" & a).Value & "E"
    sk = "*" & sh.Range("G" & a).Value & "K"
    erkek = WorksheetFunction.CountIf(siniflar, se)
    kiz = WorksheetFunction.CountIf(siniflar, sk)
    toplam = erkek + kiz
    sh.Range("I" & y).Value = toplam
    sh.Range("J" & y).Value = kiz
    sh.Range("K" & y).Value = erkek
    y = y + 1
Next a
MsgBox "İşlem tamamlandı.", vbInformation, "antonio"
End Sub

Tevfik_Kursun · 20 Aralık 2017

Sayın Antonio,
İlginize çok teşekkür ederim. Hemen deneyeceğim.
İyi geceler
Saygılarımla

Birleştirilmiş verilerin parçalandıktan sonra sayılması

Tevfik_Kursun

Ekli dosyalar

askm

Destek Ekibi

Tevfik_Kursun

askm

Destek Ekibi

Tevfik_Kursun

askm

Destek Ekibi

Tevfik_Kursun

Tevfik_Kursun

Asri

Tevfik_Kursun

askm

Destek Ekibi

Asri

Tevfik_Kursun

Ekli dosyalar

Tevfik_Kursun

Asri

Tevfik_Kursun

Asri

Tevfik_Kursun

antonio

Destek Ekibi

Tevfik_Kursun