Soru Toplam almak

k0081 · 1 Ocak 2023

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:

Plate_Parts_Only.xsr dosyasını indir - download

Plate_Parts_Only.xsr dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Haluk · 1 Ocak 2023

Ö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

.

k0081 · 2 Ocak 2023

@Haluk

Tamam hocam.

* Bu kodlardan sadeleştirmeye çalışacağım. Telşekkür ediyorum.

k0081 · 2 Ocak 2023

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...

k0081 · 2 Ocak 2023

sadeleşmiş son hali bu şekilde olmalıdır hocam

Haluk · 2 Ocak 2023

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

.

k0081 · 2 Ocak 2023

@Haluk

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

veyselemre · 2 Ocak 2023

Ö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

k0081 · 2 Ocak 2023

Çok teşekkür ediyorum. İki adet süper örnek oldu benim için., sağolun hocam.

k0081 · 2 Ocak 2023

@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 · 2 Ocak 2023

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

.

k0081 · 2 Ocak 2023

@Haluk

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

Soru Toplam almak

k0081

Plate_Parts_Only.xsr dosyasını indir - download

Haluk

𐱅𐰇𐰼𐰚

k0081

k0081

k0081

Haluk

𐱅𐰇𐰼𐰚

k0081

veyselemre

Özel Üye

k0081

k0081

Haluk

𐱅𐰇𐰼𐰚

k0081