Soru Toplam almak

Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
Merhaba arkadaşlar, --- Herkese mutlu yıllar .!

Ekteki txt dosyası üzerinde işlem yapıp sonuçları excel dosyasında;


İsimleri = D33 : D48 aralığına

toplam ağırlıklar = E33 : E48 aralığına

nasıl alabilirim ?

istenen isimler (D33 : D48)

PL5*
PL5*
PL10*
PL15*
PL25*

istenen toplam ağırlıklar (E33:E48)

19.20 ( 192x0.1 )
12.8 ( 64 x 0.2 )
...
...
...

PLxx* ifadelerinin adet ve ağırlıklarının çarpıp toplatmak. mesela bu PL5* ifadesi tek satır yazılmalıdır. oda toplamda 32 kg dır...


yardımcı arkadaşa şimdiden teşekkürler.

ilgili dosya linki:

 
Son düzenleme:

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
Önce aşağıdaki kodla verileri Excel sayfasına alın, daha sonra gerekli diğer işleri yaparsınız....

Not: Sayda adı Sheet1

C#:
Sub Test()
'   Haluk - 01/01/2023

    Dim regExp As Object, objMatches As Object
    Dim arrPattern(1 To 4) As String
    Dim myStr As String, i As Long, j As Integer
    
    Dim MyFile As Variant, myArr As Variant, myArr2 As Variant
    Dim FileNo As Long, strfile As String, lineNo As Long
    
    Sheets("Sheet1").Range("A2:E" & Rows.Count).ClearContents
    
    Sheets("Sheet1").Range("A1:E1") = Array("Mark", "Profile", "No", "Weight", "Total Weight")
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.IgnoreCase = True
    regExp.Global = True
    
    arrPattern(1) = "\s{4}(\d+)+\s"
    arrPattern(2) = "\s{6}(PL\d{1,2}\*\d+)\s"
    arrPattern(3) = "(\d+)\s*S235JR"
    arrPattern(4) = "(\d+[,.]?\d{1,2})[\n\r]"
    
    MyFile = Application.GetOpenFilename("Tekla dosyası, *.xsr", , "Dosya seçin...")
    FileNo = FreeFile

    If Not MyFile = False Then
        Open MyPath & MyFile For Input As #FreeFile
            strfile = Input(LOF(FileNo), FileNo)
        Close FileNo
        
        myArr = Split(strfile, vbLf)
        
        For i = 7 To UBound(myArr) - 1
            j = 0
            myStr = myArr(i - 1)
            For Each retData In arrPattern
            j = j + 1
                regExp.Pattern = retData
                If regExp.Test(myStr) Then
                    Set objMatches = regExp.Execute(myStr)
                    Sheets("Sheet1").Cells(i - 5, j) = objMatches.Item(0).Submatches(0)
                End If
            Next
            With Sheets("Sheet1")
                .Cells(i - 5, j + 1) = .Cells(i - 5, j) * .Cells(i - 5, j - 1)
            End With
        Next
        Erase myArr
    End If
    
    MsgBox "Veriler alındi...", vbInformation
    
    Set regExp = Nothing
    Set objMatches = Nothing
End Sub
.
 
Son düzenleme:
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
@Haluk

Tamam hocam.

* Bu kodlardan sadeleştirmeye çalışacağım. Telşekkür ediyorum.
 
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
C#:
Private Sub CommandButton1_Click()
'Haluk -1 / 1 / 2023

    Dim regExp As Object, objMatches As Object
    Dim arrPattern(1 To 3) As String
    Dim myStr As String, i As Long, j As Integer
  
    Dim MyFile As Variant, myArr As Variant, myArr2 As Variant
    Dim FileNo As Long, strfile As String, lineNo As Long
  
    Sheets("Sayfa1").Range("A1:B" & Rows.Count).ClearContents
  
    Sheets("Sayfa1").Range("A1:B1") = Array("Profile", "Total Weight")
  
    Set regExp = CreateObject("VBScript.RegExp")
  
    regExp.IgnoreCase = True
    regExp.Global = True
  
    'arrPattern(1) = "\s{4}(\d+)+\s"
    arrPattern(1) = "\s{6}(PL\d{1,2}\*\d+)\s"
    arrPattern(2) = "(\d+)\s*S235JR"
    arrPattern(3) = "(\d+[,.]?\d{1,2})[\n\r]"
  
    MyFile = Application.GetOpenFilename("Tekla dosyası, *.xsr", , "Dosya seçin...")
    FileNo = FreeFile

    If Not MyFile = False Then
        Open MyPath & MyFile For Input As #FreeFile
            strfile = Input(LOF(FileNo), FileNo)
        Close FileNo
      
        myArr = Split(strfile, vbLf)
      
        For i = 7 To UBound(myArr) - 1
            j = 0
            myStr = myArr(i - 1)
            For Each retData In arrPattern
            j = j + 1
                regExp.Pattern = retData
                If regExp.Test(myStr) Then
                    Set objMatches = regExp.Execute(myStr)
                    Sheets("sayfa1").Cells(i - 5, j) = objMatches.Item(0).Submatches(0)
                End If
            Next
            With Sheets("Sayfa1")
                .Cells(i - 5, j + 1) = .Cells(i - 5, j) * .Cells(i - 5, j - 1)
            End With
        Next
        Erase myArr
    End If
  
    MsgBox "Veriler alındi...", vbInformation
  
    Set regExp = Nothing
    Set objMatches = Nothing
End Sub
sadece iki kolon yeterli, sonraki aşama da sadeleştirme olacak hocam.

şu şekilde.



Kod üzerinden değiştirdim., ancak kod buraya kadar izin veriyor sanırım...
 
Son düzenleme:
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
sadeleşmiş son hali bu şekilde olmalıdır hocam

 

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
Sayfa düzenini ayarlarsınız.... Veya, K-L sütunlarındaki özet tabloyu başka bir sayfaya yazdırırsınız.

C#:
Sub Test2()
'   Haluk - 01/01/2023

    Dim regExp As Object, objMatches As Object
    Dim arrPattern(1 To 4) As String
    Dim myStr As String, i As Long, j As Integer
    Dim adoCN As Object, strSQL As String, RS As Object
    
    Dim MyFile As Variant, myArr As Variant, myArr2 As Variant
    Dim FileNo As Long, strfile As String, lineNo As Long
    
    Sheets("Sheet1").Range("A2:F" & Rows.Count).ClearContents
    Sheets("Sheet1").Range("K2:L" & Rows.Count).ClearContents
    
    Sheets("Sheet1").Range("A1:F1") = Array("Mark", "Profile", "No", "Weight", "Plate", "Total Weight")
    Sheets("Sheet1").Range("K1:L1") = Array("Plate", "Total Weight")
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.IgnoreCase = True
    regExp.Global = True
    
    arrPattern(1) = "\s{4}(\d+)+\s"
    arrPattern(2) = "\s{6}(PL\d{1,2}\*\d+)\s"
    arrPattern(3) = "(\d+)\s*S235JR"
    arrPattern(4) = "(\d+[,.]?\d{1,2})[\n\r]"
    
    MyFile = Application.GetOpenFilename("Tekla dosyası, *.xsr", , "Dosya seçin...")
    FileNo = FreeFile

    If Not MyFile = False Then
        Open MyPath & MyFile For Input As #FreeFile
            strfile = Input(LOF(FileNo), FileNo)
        Close FileNo
        
        myArr = Split(strfile, vbLf)
        
        For i = 7 To UBound(myArr) - 2
            j = 0
            myStr = myArr(i - 1)
            For Each retData In arrPattern
            j = j + 1
                regExp.Pattern = retData
                If regExp.Test(myStr) Then
                    Set objMatches = regExp.Execute(myStr)
                    Sheets("Sheet1").Cells(i - 5, j) = objMatches.Item(0).Submatches(0)
                End If
            Next
            With Sheets("Sheet1")
                .Cells(i - 5, j + 1) = Split(.Cells(i - 5, j - 2), "*")(0)
                .Cells(i - 5, j + 2) = .Cells(i - 5, j) * .Cells(i - 5, j - 1)
            End With
        Next
        Erase myArr
    End If
    
'   Ozet Tablo
    MyFile = ThisWorkbook.FullName
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    adoCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & MyFile & ";Extended Properties=Excel 8.0;"
    
    strSQL = "Select [Plate], Sum([Total Weight]) From [Sheet1$] Group By [Plate]"
    
    RS.CursorType = 1 'adOpenKeyset
    RS.Open strSQL, adoCN
    
    Sheets("Sheet1").Range("K2").CopyFromRecordset RS
    
    MsgBox "Veriler alındi...", vbInformation
    
    Set regExp = Nothing
    Set objMatches = Nothing
    Set RS = Nothing
    Set adoCN = Nothing
End Sub

.
 
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
@Haluk

Hocam elinize sağlık. Tamamdır... Çok teşekkürler.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Örnek olsun ;
Kod:
Sub veriAlADO()
    Dim pth$, strCon$, strSql$(0 To 2), fName$(0 To 2), rs As Object

    pth = "C:\Users\pc\Downloads\"
    fName(0) = "Plate_Parts_Only.xsr"
    fName(1) = "sil.txt"
    fName(2) = "schema.ini"

    FileCopy pth & fName(0), pth & fName(1)

    strSql(0) = "[" & fName(1) & "]" & vbCrLf & _
                "ColNameHeader = True" & vbCrLf & _
                "Format = FixedLength" & vbCrLf & _
                "MaxScanRows = 25" & vbCrLf & _
                "CharacterSet = ANSI" & vbCrLf & _
                "DateFormat = MM / DD / YYYY" & vbCrLf & _
                "DateTimeFormat=MM/DD/YYYY hh:nn,ss" & vbCrLf & _
                "Col1=Mark Double Width 14" & vbCrLf & _
                "Col2=Profile Text Width 11" & vbCrLf & _
                "Col3=No Double Width 8" & vbCrLf & _
                "Col4=Grade Text Width 10" & vbCrLf & _
                "Col5=Length Double Width 12" & vbCrLf & _
                "Col6=Area Double Width 10" & vbCrLf & _
                "Col7=Weight Double Width 12" & vbCrLf & _
                "DecimalSymbol=." & vbCrLf & _
                "StartRow = 5"

    Open pth & fName(2) For Output As #99
    Print #99, strSql(0)
    Close #99

    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Text;HDR=YES';Data Source=" & pth

    strSql(1) = "SELECT Mark,Profile,[No],Weight, LEFT(Profile,INSTR(Profile,'*')-1) AS Plate, " & _
                "[No]*Weight AS [Total Weight] FROM " & _
                fName(1) & " WHERE Mark IS NOT NULL "

    strSql(2) = "SELECT Plate, SUM([Total Weight]) FROM " & _
                " ( " & strSql(1) & " ) GROUP BY Plate"

    With Sheets("Sheet1")
        .Cells.ClearContents
        .Range("A1:F1") = Array("Mark", "Profile", "No", "Weight", "Plate", "Total Weight")
        .Range("K1:L1") = Array("Plate", "Total Weight")
        Set rs = CreateObject("ADODB.Recordset")
        rs.Open strSql(1), strCon
        .Range("A2").CopyFromRecordset rs
        rs.Close

        rs.Open strSql(2), strCon
        .Range("K2").CopyFromRecordset rs
        rs.Close
    End With

    Kill pth & fName(1)

End Sub
 
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
Çok teşekkür ediyorum. İki adet süper örnek oldu benim için., sağolun hocam.
 
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
@Haluk

hocam tabloyu D sütununa aldım.

j = 3

başlıklarıda düzenledim.


Sheets("Rapor02").Range("D60:I" & Rows.Count).ClearContents
Sheets("Rapor02").Range("K2:L" & Rows.Count).ClearContents

Sheets("Rapor02").Range("D60:I60") = Array("Mark", "Profile", "No", "Weight", "Plate", "Total Weight")
Sheets("Rapor02").Range("K1:L1") = Array("Plate", "Total Weight")

yalnız ana tabloyu D61 den başlatmalıyım. bunu nasıl yapabilirim ? epey uğraştım ama olmadı.
 

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
C#:
Sub Test3()
'   Haluk - 01/01/2023

    Dim regExp As Object, objMatches As Object
    Dim arrPattern(1 To 4) As String
    Dim myStr As String, i As Long, j As Integer
    Dim adoCN As Object, strSQL As String, RS As Object
    
    Dim MyFile As Variant, myArr As Variant
    Dim FileNo As Long, strfile As String, lineNo As Long
    
    Sheets("Rapor02").Range("D60:I" & Rows.Count).ClearContents
    Sheets("Rapor02").Range("K2:L" & Rows.Count).ClearContents
    
    Sheets("Rapor02").Range("D60:I60") = Array("Mark", "Profile", "No", "Weight", "Plate", "Total Weight")
    Sheets("Rapor02").Range("K1:L1") = Array("Plate", "Total Weight")
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.IgnoreCase = True
    regExp.Global = True
    
    arrPattern(1) = "\s{4}(\d+)\s"
    arrPattern(2) = "\s{6}(PL\d{1,2}\*\d+)\s"
    arrPattern(3) = "(\d+)\s*S235JR"
    arrPattern(4) = "(\d+[,.]?\d{1,2})[\n\r]"
    
    MyFile = Application.GetOpenFilename("Tekla dosyası, *.xsr", , "Dosya seçin...")
    FileNo = FreeFile

    If Not MyFile = False Then
        Open MyPath & MyFile For Input As #FreeFile
            strfile = Input(LOF(FileNo), FileNo)
        Close FileNo
        
        myArr = Split(strfile, vbLf)
        
        iRow = 61
        For i = 7 To UBound(myArr) - 2
            j = 3
            myStr = myArr(i - 1)
            For Each retData In arrPattern
            j = j + 1
                regExp.Pattern = retData
                If regExp.Test(myStr) Then
                    Set objMatches = regExp.Execute(myStr)
                    Sheets("Rapor02").Cells(iRow, j) = objMatches.Item(0).Submatches(0)
                End If
            Next
            With Sheets("Rapor02")
                .Cells(iRow, j + 1) = Split(.Cells(iRow, j - 2), "*")(0)
                .Cells(iRow, j + 2) = .Cells(iRow, j) * .Cells(iRow, j - 1)
            End With
            iRow = iRow + 1
        Next
        Erase myArr
    End If
    
'   Ozet Tablo
    MyFile = ThisWorkbook.FullName
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    adoCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & MyFile & ";Extended Properties=Excel 8.0;"
    
    strSQL = "Select [Plate], Sum([Total Weight]) From [Rapor02$D60:I] Group By [Plate]"
    
    RS.CursorType = 1 'adOpenKeyset
    RS.Open strSQL, adoCN
    
    Sheets("Rapor02").Range("K2").CopyFromRecordset RS
    
    MsgBox "Veriler alındi...", vbInformation
    
    Set regExp = Nothing
    Set objMatches = Nothing
    Set RS = Nothing
    Set adoCN = Nothing
End Sub
.
 
Katılım
17 Haziran 2008
Mesajlar
1,871
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Altın Üyelik Bitiş Tarihi
26-03-2020
@Haluk

Tamamdır... elinize sağlık hocam. Teşekkürler.
 
Üst