ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

9KiTTi · #1

ขออนุญาตสอบถามครับ ผมเขียนVBA เพื่อคำนวณหาผลรวมในชีทชื่อCOMBINED_DATA_DTTM โดยหาผลรวมในแต่ละแถวในคอลัมน์TลงมาในชีทCOMBINED_DATA_DTTM โดยที่คอลัมน์Xลงมามีคำว่าY นำมาวางในชีทDTTM ตั้งแต่แถวD4ลงมา โดยแถวที่วางผลรวมต้องมีข้อมูลในคอลัมน์B4ลงมาของชีทDTTM ตรงกับข้อมูลในคอลัมน์B2ลงมาในชีทCOMBINED_DATA_DTTM แต่ผลรวมออกมาเป็น 0 และออกไม่ครบทุกคอลัมน์ และพอรัน code หัวแถวก็เปลี่ยน รบกวนขอคำแนะนำด้วยครับ ขอบพระคุณครับ

Code: Select all

Sub CalculateAndPlaceValues()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRowSource As Long, lastRowDest As Long
    Dim i As Long, j As Long
    Dim totalSum As Double
    Dim countUnits As Long
    Dim unitTotal As Double, bathTotal As Double
    Dim currentVal As String
    Dim matchedRow As Long
    
    ' กำหนดชีทต้นทางและปลายทาง
    Set wsSource = ThisWorkbook.Sheets("COMBINED_DATA_DTTM")
    Set wsDest = ThisWorkbook.Sheets("DTTM")
    
    ' หาจำนวนแถวสุดท้ายของแต่ละชีท
    lastRowSource = wsSource.Cells(wsSource.Rows.count, "B").End(xlUp).Row
    lastRowDest = wsDest.Cells(wsDest.Rows.count, "B").End(xlUp).Row
    
    ' วนลูปข้อมูลในชีทปลายทาง (DTTM) เริ่มจากแถวที่ 4
    For j = 4 To lastRowDest
        currentVal = wsDest.Cells(j, "B").Value
        
        ' หาและคำนวณผลรวมในชีท COMBINED_DATA_DTTM
        totalSum = 0
        countUnits = 0
        unitTotal = 0
        bathTotal = 0
        
        For i = 2 To lastRowSource
            ' ตัวอักษรจากคอลัมน์ B ที่ 7 ถึง 21
            If Mid(wsSource.Cells(i, "B").Value, 7, 15) = currentVal Then
                If wsSource.Cells(i, "X").Value = "Y" Then
                    totalSum = totalSum + wsSource.Cells(i, "T").Value
                End If
            End If
            
            ' คำนวณ unit และ bath ตามเงื่อนไข
            If wsSource.Cells(i, "X").Value = "Y" And wsSource.Cells(i, "M").Value = wsDest.Cells(2, j).Value Then
                If wsDest.Cells(3, j).Value = "unit" Then
                    unitTotal = unitTotal + wsSource.Cells(i, "T").Value
                ElseIf wsDest.Cells(3, j).Value = "Bath" Then
                    bathTotal = bathTotal + wsSource.Cells(i, "T").Value
                End If
            End If
        Next i
        
        ' วางค่าผลรวมในคอลัมน์ D ของชีทปลายทาง
        wsDest.Cells(j, "D").Value = totalSum
        
        ' วางค่า unit ในแถวที่ 3
        wsDest.Cells(3, j).Value = unitTotal
        
        ' วางค่า bath ในแถวที่ 4
        wsDest.Cells(4, j).Value = bathTotal
    Next j

    MsgBox "Calculation and data placement complete!"
End Sub

9KiTTi · #2

ผมปรับให้คำสั่งใหม่ แต่ไม่แสดงผลรวมทั้งหมดที่รงตรมเงื่อนไข จะแสดงแค่จำนวนในแถวแรกที่เจอ และไม่อีกคอลัมน์ไม่แสดงจำนวน รบกวนขอคำแนะดวยครับ

Code: Select all

Sub CalculateAndCopyData()
    Dim wsCombined As Worksheet
    Dim wsDTTM As Worksheet
    Dim lastRowCombined As Long
    Dim lastRowDTTM As Long
    Dim i As Long, j As Long
    Dim total As Double
    Dim found As Boolean
    Dim combinedValue As String
    Dim dttmValue As String
    Dim dttmCompareValue As String
    
    ' กำหนดชีท
    Set wsCombined = ThisWorkbook.Sheets("COMBINED_DATA_DTTM")
    Set wsDTTM = ThisWorkbook.Sheets("DTTM")

    ' หาค่าแถวสุดท้ายของ COMBINED_DATA_DTTM
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.count, "X").End(xlUp).Row
    
    ' หาค่าแถวสุดท้ายของ DTTM โดยเริ่มจาก B4 ลงมา
    lastRowDTTM = wsDTTM.Cells(wsDTTM.Rows.count, "B").End(xlUp).Row

    ' ดึงค่าจากแถวที่ 3 ของชีท DTTM เพื่อนำมาเปรียบเทียบ
    dttmCompareValue = Mid(wsDTTM.Range("B3").Value, 7, 15) ' ดึงค่าตัวอักษรที่ 7 ถึง 21

    ' วนลูปผ่านแถวต่างๆ ในชีท COMBINED_DATA_DTTM
    For i = 2 To lastRowCombined
        If wsCombined.Range("X" & i).Value = "Y" Then ' ถ้ามีคำว่า "Y" ในคอลัมน์ X
            total = wsCombined.Range("T" & i).Value ' ค่าผลรวมในคอลัมน์ T
            combinedValue = wsCombined.Range("AB" & i).Value ' ค่าจากคอลัมน์ AB
            found = False ' รีเซ็ตตัวแปร found

            ' ค้นหาข้อมูลที่ตรงกันในคอลัมน์ B ของชีท DTTM เริ่มจากแถว 4
            For j = 4 To lastRowDTTM
                dttmValue = wsDTTM.Range("B" & j).Value ' ค่าจากคอลัมน์ B ของชีท DTTM
                
                ' ตรวจสอบข้อมูลว่า ตรงกับค่าในคอลัมน์ AB และคอลัมน์ D ยังไม่มีข้อมูล
                ' และตรวจสอบข้อมูลแถวที่ 3 ว่าตรงกับค่าใน COMBINED_DATA_DTTM
                If combinedValue = dttmValue And wsDTTM.Range("D" & j).Value = "" And combinedValue = dttmCompareValue Then
                    ' วางผลรวมในคอลัมน์ D ของชีท DTTM
                    wsDTTM.Range("D" & j).Value = total
                    found = True
                    Exit For
                End If
            Next j
        End If
    Next i
End Sub

9KiTTi · #3

ขออนุญาติครับ ตอนนี้ผมสามารถคำนวณได้ถูกต้องแล้ว เหลือที่ทำไม่ได้คือ ให้ข้อมูลมาวางให้ตรงกับคอลัมน์ในชีทDTTM โดยที่จำนวนตัวอักษรหลักที่7ถึง21ต้องตรงกับข้อมูลในคอลัมน์BชีทCOMBINED_DATA_DTTM ครับ ขอคำแนะนำด้วยครับ

Code: Select all

Sub ReportDTTM()
    Dim wsCombined As Worksheet
    Dim wsDTTM As Worksheet
    Dim lastRowCombined As Long
    Dim lastRowDTTM As Long
    Dim i As Long, j As Long
    Dim total As Double
    Dim combinedValue As String
    Dim dttmValue As String

    ' กำหนดชีท
    Set wsCombined = ThisWorkbook.Sheets("COMBINED_DATA_DTTM")
    Set wsDTTM = ThisWorkbook.Sheets("DTTM")

    ' หาค่าแถวสุดท้ายของ COMBINED_DATA_DTTM
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.count, "X").End(xlUp).Row
    
    ' หาค่าแถวสุดท้ายของ DTTM โดยเริ่มจาก B4 ลงมา
    lastRowDTTM = wsDTTM.Cells(wsDTTM.Rows.count, "B").End(xlUp).Row
    
    ' ลบข้อมูลในคอลัมน์ D ตั้งแต่ D4 ถึงแถวสุดท้ายที่มีข้อมูล
    If lastRowDTTM >= 4 Then
        wsDTTM.Range("D4:D" & lastRowDTTM).ClearContents
    End If

    ' วนลูปผ่านแถวต่างๆ ในชีท COMBINED_DATA_DTTM
    For i = 2 To lastRowCombined
        If wsCombined.Range("X" & i).Value = "Y" Then ' ถ้ามีคำว่า "Y" ในคอลัมน์ X
            total = wsCombined.Range("T" & i).Value ' ค่าผลรวมในคอลัมน์ T
            combinedValue = wsCombined.Range("AB" & i).Value ' ค่าจากคอลัมน์ AB

            ' ค้นหาข้อมูลที่ตรงกันในคอลัมน์ B ของชีท DTTM เริ่มจากแถว 4
            For j = 4 To lastRowDTTM
                dttmValue = wsDTTM.Range("B" & j).Value ' ค่าจากคอลัมน์ B ของชีท DTTM
                
                ' ตรวจสอบข้อมูลว่า ตรงกับค่าในคอลัมน์ AB และคอลัมน์ D ยังไม่มีข้อมูล
                If combinedValue = dttmValue Then
                    ' ถ้าคอลัมน์ D ยังไม่มีข้อมูล จะวางผลรวมในคอลัมน์ D
                    If wsDTTM.Range("D" & j).Value = "" Then
                        wsDTTM.Range("D" & j).Value = total
                    Else
                        ' ถ้ามีข้อมูลแล้ว จะทำการเพิ่มผลรวม
                        wsDTTM.Range("D" & j).Value = wsDTTM.Range("D" & j).Value + total
                    End If

                    ' ตั้งค่าฟอร์แมตให้มีเลขทศนิยม 2 หลักและเครื่องหมายหลักพัน
                    wsDTTM.Range("D" & j).NumberFormat = "#,##0.00"
                End If
            Next j
        End If
    Next i

    ' ตรวจสอบและใส่เครื่องหมาย "-" ในช่องที่ไม่มีข้อมูลในคอลัมน์ D ตั้งแต่ D4
    For j = 4 To lastRowDTTM
        If wsDTTM.Range("D" & j).Value = "" Then
            wsDTTM.Range("D" & j).Value = "-" ' ใส่เครื่องหมาย "-" ถ้าช่องว่าง
            wsDTTM.Range("D" & j).HorizontalAlignment = xlCenter ' จัดให้อยู่กลางเซลล์
        End If
    Next j
End Sub

puriwutpokin · #4

ปรับตามนี้ครับ

Code: Select all

Sub ReportDTTM()
    Dim wsCombined As Worksheet
    Dim wsDTTM As Worksheet
    Dim lastRowCombined As Long
    Dim lastRowDTTM As Long
    Dim i As Long, j As Long
    Dim total As Double
    Dim combinedValue As String
    Dim dttmValue As String

    ' กำหนดชีท
    Set wsCombined = ThisWorkbook.Sheets("COMBINED_DATA_DTTM")
    Set wsDTTM = ThisWorkbook.Sheets("DTTM")

    ' หาค่าแถวสุดท้ายของ COMBINED_DATA_DTTM
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.count, "X").End(xlUp).Row
    
    ' หาค่าแถวสุดท้ายของ DTTM โดยเริ่มจาก B4 ลงมา
    lastRowDTTM = wsDTTM.Cells(wsDTTM.Rows.count, "B").End(xlUp).Row
    
    ' ลบข้อมูลในคอลัมน์ D ตั้งแต่ D4 ถึงแถวสุดท้ายที่มีข้อมูล
    If lastRowDTTM >= 4 Then
        wsDTTM.Range("D4:D" & lastRowDTTM).ClearContents
    End If

    ' วนลูปผ่านแถวต่างๆ ในชีท COMBINED_DATA_DTTM
    For i = 2 To lastRowCombined
        If wsCombined.Range("X" & i).Value = "Y" Then ' ถ้ามีคำว่า "Y" ในคอลัมน์ X
            total = wsCombined.Range("T" & i).Value ' ค่าผลรวมในคอลัมน์ T
            combinedValue = wsCombined.Range("AB" & i).Value ' ค่าจากคอลัมน์ AB

            ' ค้นหาข้อมูลที่ตรงกันในคอลัมน์ B ของชีท DTTM เริ่มจากแถว 4
            For j = 4 To lastRowDTTM
                dttmValue = wsDTTM.Range("B" & j).Value ' ค่าจากคอลัมน์ B ของชีท DTTM
                
                ' ตรวจสอบข้อมูลว่า ตรงกับค่าในคอลัมน์ AB และคอลัมน์ D ยังไม่มีข้อมูล
                If combinedValue = dttmValue Then
                    ' ถ้าคอลัมน์ D ยังไม่มีข้อมูล จะวางผลรวมในคอลัมน์ D
                    x = Application.Match("*" & wsCombined.Range("B" & i), wsDTTM.Range("D3:E3"), 0) + 3
                    If wsDTTM.Cells(j, x).Value = "" Then
                        wsDTTM.Cells(j, x).Value = total
                    Else
                        ' ถ้ามีข้อมูลแล้ว จะทำการเพิ่มผลรวม
                        wsDTTM.Cells(j, x).Value = wsDTTM.Cells(j, x).Value + total
                    End If

                    ' ตั้งค่าฟอร์แมตให้มีเลขทศนิยม 2 หลักและเครื่องหมายหลักพัน
                    wsDTTM.Cells(j, x).NumberFormat = "#,##0.00"
                End If
            Next j
        End If
    Next i

    ' ตรวจสอบและใส่เครื่องหมาย "-" ในช่องที่ไม่มีข้อมูลในคอลัมน์ D ตั้งแต่ D4
    For j = 4 To lastRowDTTM
        If wsDTTM.Range("D" & j).Value = "" Then
            wsDTTM.Range("D" & j).Value = "-" ' ใส่เครื่องหมาย "-" ถ้าช่องว่าง
            wsDTTM.Range("D" & j).HorizontalAlignment = xlCenter ' จัดให้อยู่กลางเซลล์
        End If
    Next j
End Sub

9KiTTi · #5

puriwutpokin wrote: Fri Oct 11, 2024 1:02 pm ปรับตามนี้ครับ

Code: Select all

Sub ReportDTTM()
    Dim wsCombined As Worksheet
    Dim wsDTTM As Worksheet
    Dim lastRowCombined As Long
    Dim lastRowDTTM As Long
    Dim i As Long, j As Long
    Dim total As Double
    Dim combinedValue As String
    Dim dttmValue As String

    ' กำหนดชีท
    Set wsCombined = ThisWorkbook.Sheets("COMBINED_DATA_DTTM")
    Set wsDTTM = ThisWorkbook.Sheets("DTTM")

    ' หาค่าแถวสุดท้ายของ COMBINED_DATA_DTTM
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.count, "X").End(xlUp).Row
    
    ' หาค่าแถวสุดท้ายของ DTTM โดยเริ่มจาก B4 ลงมา
    lastRowDTTM = wsDTTM.Cells(wsDTTM.Rows.count, "B").End(xlUp).Row
    
    ' ลบข้อมูลในคอลัมน์ D ตั้งแต่ D4 ถึงแถวสุดท้ายที่มีข้อมูล
    If lastRowDTTM >= 4 Then
        wsDTTM.Range("D4:D" & lastRowDTTM).ClearContents
    End If

    ' วนลูปผ่านแถวต่างๆ ในชีท COMBINED_DATA_DTTM
    For i = 2 To lastRowCombined
        If wsCombined.Range("X" & i).Value = "Y" Then ' ถ้ามีคำว่า "Y" ในคอลัมน์ X
            total = wsCombined.Range("T" & i).Value ' ค่าผลรวมในคอลัมน์ T
            combinedValue = wsCombined.Range("AB" & i).Value ' ค่าจากคอลัมน์ AB

            ' ค้นหาข้อมูลที่ตรงกันในคอลัมน์ B ของชีท DTTM เริ่มจากแถว 4
            For j = 4 To lastRowDTTM
                dttmValue = wsDTTM.Range("B" & j).Value ' ค่าจากคอลัมน์ B ของชีท DTTM
                
                ' ตรวจสอบข้อมูลว่า ตรงกับค่าในคอลัมน์ AB และคอลัมน์ D ยังไม่มีข้อมูล
                If combinedValue = dttmValue Then
                    ' ถ้าคอลัมน์ D ยังไม่มีข้อมูล จะวางผลรวมในคอลัมน์ D
                    x = Application.Match("*" & wsCombined.Range("B" & i), wsDTTM.Range("D3:E3"), 0) + 3
                    If wsDTTM.Cells(j, x).Value = "" Then
                        wsDTTM.Cells(j, x).Value = total
                    Else
                        ' ถ้ามีข้อมูลแล้ว จะทำการเพิ่มผลรวม
                        wsDTTM.Cells(j, x).Value = wsDTTM.Cells(j, x).Value + total
                    End If

                    ' ตั้งค่าฟอร์แมตให้มีเลขทศนิยม 2 หลักและเครื่องหมายหลักพัน
                    wsDTTM.Cells(j, x).NumberFormat = "#,##0.00"
                End If
            Next j
        End If
    Next i

    ' ตรวจสอบและใส่เครื่องหมาย "-" ในช่องที่ไม่มีข้อมูลในคอลัมน์ D ตั้งแต่ D4
    For j = 4 To lastRowDTTM
        If wsDTTM.Range("D" & j).Value = "" Then
            wsDTTM.Range("D" & j).Value = "-" ' ใส่เครื่องหมาย "-" ถ้าช่องว่าง
            wsDTTM.Range("D" & j).HorizontalAlignment = xlCenter ' จัดให้อยู่กลางเซลล์
        End If
    Next j
End Sub

ขอบพระคุณครับ ใช้งานได้แล้วครับ แต่ขออนุญาตสอบถามเพิ่มครับกรณีที่ข้อมูลในคอลัมน์งวดมีจำนวนไม่แน่นอนตรงปรับอย่างไรครับ

9KiTTi · #6

ปรับเรื่องงวดได้แล้วครับ

9KiTTi · #7

ขออนุญาตสอบถามต่อครับ เนื่องจากเป็นงานเดียวกันครับ ผมเขียนคำสั่งเพื่อหาผลรวมและจำนวนชิ้นมาวางในแต่ละแถวและแต่ละคอลัมน์ แยกเป็นเป็นจำนวนเงินและจำนวนชิ้นที่ได้รับเงิน โปรแกรมรันทำงานได้ปกติ แต่ไม่มีข้อมูลขึ้น และจำนวนคอลัมน์ในแถวที่3ของsectionมีจำนวนแน่นอน รบกวนขอคำแนะนำด้วยครับ ขอบพระคุณครับ

Code: Select all

Sub CalculateAndPlaceValues()
    Dim wsCombined As Worksheet
    Dim wsDTTM As Worksheet
    Dim lastRowCombined As Long
    Dim lastRowDTTM As Long
    Dim i As Long
    Dim sumBath As Double
    Dim targetRow As Long
    Dim targetBathCol As Variant
    Dim targetUnitCol As Variant
    Dim targetSectionCol As Variant
    Dim sumValue As Double

    ' กำหนดชีทที่ใช้
    Set wsCombined = ThisWorkbook.Sheets("COMBINED_DATA_DTTM")
    Set wsDTTM = ThisWorkbook.Sheets("DTTM")

    ' ค้นหาแถวสุดท้ายในชีท COMBINED_DATA_DTTM
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.count, "T").End(xlUp).Row
    ' ค้นหาแถวสุดท้ายในชีท DTTM
    lastRowDTTM = wsDTTM.Cells(wsDTTM.Rows.count, "B").End(xlUp).Row

    ' ค้นหาคอลัมน์ที่มีคำว่า "Bath" ในแถวที่ 3
    targetBathCol = Application.Match("Bath", wsDTTM.Rows(3), 0)
    ' ค้นหาคอลัมน์ที่มีคำว่า "unit" ในแถวที่ 3
    targetUnitCol = Application.Match("unit", wsDTTM.Rows(3), 0)
    ' ค้นหาคอลัมน์ที่มีคำว่า "Section" ในแถวที่ 2
    targetSectionCol = Application.Match("Section", wsDTTM.Rows(2), 0)

    ' ตรวจสอบว่าคอลัมน์ "Bath" พบหรือไม่
    If IsError(targetBathCol) Then
        MsgBox "ไม่พบคอลัมน์ 'Bath' ในแถวที่ 3", vbCritical
        Exit Sub
    End If

    ' ตรวจสอบว่าคอลัมน์ "unit" พบหรือไม่
    If IsError(targetUnitCol) Then
        MsgBox "ไม่พบคอลัมน์ 'unit' ในแถวที่ 3", vbCritical
        Exit Sub
    End If

    ' ตรวจสอบว่าคอลัมน์ "Section" พบหรือไม่
    If IsError(targetSectionCol) Then
        MsgBox "ไม่พบคอลัมน์ 'Section' ในแถวที่ 2", vbCritical
        Exit Sub
    End If

    ' ลูปผ่านแต่ละแถวในชีท COMBINED_DATA_DTTM
    For i = 4 To lastRowCombined
        If wsCombined.Cells(i, "X").Value = "ชดเชย" Then
            ' คำนวณผลรวมในคอลัมน์ T
            sumBath = sumBath + wsCombined.Cells(i, "T").Value
            
            ' ตรวจสอบเงื่อนไขในคอลัมน์ M
            If wsCombined.Cells(i, "M").Value = "AA" Then
                ' วางค่าในแถวที่ 3 และค้นหาแถวในชีท DTTM ที่ตรงกัน
                targetRow = Application.Match(wsCombined.Cells(i, "B").Value, wsDTTM.Range("B4:B" & lastRowDTTM), 0) + 3
                If Not IsError(targetRow) Then
                    wsDTTM.Cells(targetRow, targetBathCol).Value = wsCombined.Cells(i, "T").Value
                    wsDTTM.Cells(targetRow, targetUnitCol).Value = wsCombined.Cells(i, "T").Value
                End If
            End If
        End If
        
        ' วางค่าจากคอลัมน์ "Section" ไปที่คอลัมน์ "Bath"
        Dim sectionValue As Variant
        sectionValue = wsCombined.Cells(i, targetSectionCol).Value
        If Not IsEmpty(sectionValue) Then
            wsDTTM.Cells(targetRow, targetBathCol).Value = sectionValue
            sumValue = sumValue + sectionValue  ' คำนวณผลรวม
        End If
    Next i

    ' วางผลรวมในแถวที่ 4 ในชีท DTTM
    wsDTTM.Cells(4, targetBathCol).Value = sumBath
    ' วางผลรวมจากคอลัมน์ Section
    wsDTTM.Cells(2, targetBathCol).Value = sumValue  ' วางที่แถวที่ 2 ของคอลัมน์ "Sum"
End Sub

Snasui Excel Forum

File Anatomy Add-in: ตรวจสอบโครงสร้างไฟล์ Excel อย่างมืออาชีพ

ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

Re: ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

Re: ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

Re: ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

Re: ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

Re: ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท

Re: ขออนุญาตช่วยปรับVBAในหาผลรวมในชีทข้อมูลมาวางอีกชีท