分類: chatGPT

Excel VBA用SQL語法找出生產報工資料員工每日最早一筆報工開始與最晚一筆報工結束做工時統計，資料來源為自己的寫法.

chatgpt提醒Make sure to add a reference to the “Microsoft ActiveX Data Objects” library in your VBA project by going to “Tools” > “References” and checking the appropriate version (e.g., “Microsoft ActiveX Data Objects x.x Library”). 實測office2010 選用 2.8 library是可行。

Sub GetGroupedData()
    ' Define variables
    Dim wsResult As Worksheet
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim rngResult As Range
    Dim strSQL As String
    Dim connString As String
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim rowIndex As Long
    Dim colIndex As Long
    Dim strSourceRng As String
    ' Set the source worksheet
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    
     Dim lastRow As Long
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    
    strSourceRng = Trim("[Sheet1$A1:F" + Trim(Str(lastRow)) + "]")
        
    ' Check if the result sheet already exists
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("Result")
    On Error GoTo 0
    
    ' If the result sheet exists, clear its contents
    If Not wsResult Is Nothing Then
        Application.DisplayAlerts = False
        wsResult.Cells.Clear
        Application.DisplayAlerts = True
    Else
        ' If the result sheet doesn't exist, create it
        Set wsResult = ThisWorkbook.Worksheets.Add
        wsResult.Name = "Result"
    End If
    
    ' Define the range where the result will be displayed
    Set rngResult = wsResult.Range("A1")
    
    ' Connection string (Excel version-dependent)
    connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";" & _
                 "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    
    ' SQL query to retrieve the grouped data
    'strSQL = "SELECT col1, col2, col3, col4, MIN(col5) AS MinValue, MAX(col6) AS MaxValue FROM [Sheet1$A1:N274] " & _
             "GROUP BY col1, col2, col3, col4"
    
    strSQL = "SELECT col1, col2, col3, col4, MIN(col5) AS MinValue, MAX(col6) AS MaxValue FROM " & strSourceRng & _
             "GROUP BY col1, col2, col3, col4"
    'wsSource.Range("N3").Value = strSQL
    
    ' Create a connection object
    Set cn = New ADODB.Connection
    
    ' Open the connection
    cn.Open connString
    
    ' Create a recordset object
    Set rs = New ADODB.Recordset
    
    ' Execute the query and populate the recordset
    rs.Open strSQL, cn
    
    ' Write the column headers to the result range
    For colIndex = 1 To rs.Fields.Count
        rngResult.Offset(0, colIndex - 1).Value = rs.Fields(colIndex - 1).Name
    Next colIndex
        rngResult.Offset(0, colIndex - 1).Value = "時數(HR)"
    ' Write the data to the result range
    rowIndex = 1
    Do Until rs.EOF
        For colIndex = 1 To rs.Fields.Count
            rngResult.Offset(rowIndex, colIndex - 1).Value = rs.Fields(colIndex - 1).Value
        Next colIndex
               ' Convert col5 and col6 to DateTime values
        Dim dt1 As Date
        Dim dt2 As Date
        dt1 = CDate(rs.Fields("MinValue").Value)
        dt2 = CDate(rs.Fields("MaxValue").Value)
        
        ' Calculate the difference and add as col7
        Dim diff As Double
        diff = dt2 - dt1
        rngResult.Offset(rowIndex, rs.Fields.Count).Value = Round(diff * 24, 2)
        
        rs.MoveNext
        rowIndex = rowIndex + 1
    Loop
    
    ' Clean up
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    
    ' Format the result range as desired
    
    ' Optional: Autofit columns in the result range
    wsResult.Columns.AutoFit
End Sub
其中組合SQL語法from 片段時原本程式碼為
 ' Set the name of the sheet containing the data
    sheetName = "Sheet1"
    
    ' Set the range of data in Sheet1
    Set rngData = ThisWorkbook.Worksheets(sheetName).UsedRange
  
    ' SQL query to retrieve data from Sheet1
    strSQL = "SELECT * FROM [" & sheetName & "$" & rngData.Address & "]"
會有錯誤才改成自行抓取最後一筆，手動組成範圍。
原本不使用VBA與SQL語法，單純用excel Function來做
1.手動找出distinct的 上班日、員工代號、姓名、報工別
2.將上下工時間由字串改成日期時間 =DATEVALUE(上工時間) + TIMEVALUE(上工時間)，這樣才能做運算，算出時數。
3.=MAX(IF((A:A=L2)*(B:B=M2)*(D:D=O2),I:I)) 找出MAX值
  =MIN(IF((A:A=L2)*(B:B=M2)*(D:D=O2),H:H)) 找出MIN值
  其中L、M、O欄位第1.步驟抓出之distinct值 A、B、D為原始資料
4.Instead of pressing Enter, use Ctrl+Shift+Enter to enter the formula as an array formula. This will enclose the formula in curly braces {} and calculate the distinct values based on the three columns
5.差異為=(MAX-MIN)*24

測試使用chatgpt產生語法針對excel檔案按照某欄資料分組，各組資料複製到各自新的頁面

第一次指令 design VBA code to move data from Sheet1 to newly inserted sheets based on certain group

Sub MoveData()

    Dim lastRow As Long
    Dim i As Long
    Dim groupName As String
    Dim ws As Worksheet
    Dim newWs As Worksheet
    
    'Get last row of data in Sheet1
    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Loop through each row of data in Sheet1
    For i = 2 To lastRow 'Assuming data starts in row 2
        
        'Get the group name from column A
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value
        
        'Check if there is already a worksheet with the group name
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets(groupName)
        On Error GoTo 0
        
        'If there is no worksheet with the group name, insert a new worksheet
        If ws Is Nothing Then
            Set newWs = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newWs.Name = groupName
        Else
            Set newWs = ws
        End If
        
        'Copy the data from Sheet1 to the new worksheet
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy Destination:=newWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        
    Next i
    
End Sub

第二次指令 please use 4th column as group and copy first row as header to every new sheet

Sub MoveData()

    Dim lastRow As Long
    Dim i As Long
    Dim groupName As String
    Dim ws As Worksheet
    Dim newWs As Worksheet
    
    'Get last row of data in Sheet1
    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Copy header row to every new sheet
    ThisWorkbook.Worksheets("Sheet1").Rows(1).Copy
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
            ws.Rows(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next ws
    
    'Loop through each row of data in Sheet1
    For i = 2 To lastRow 'Assuming data starts in row 2
        
        'Get the group name from column D
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, 4).Value
        
        'Check if there is already a worksheet with the group name
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets(groupName)
        On Error GoTo 0
        
        'If there is no worksheet with the group name, insert a new worksheet
        If ws Is Nothing Then
            Set newWs = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newWs.Name = groupName
        Else
            Set newWs = ws
        End If
        
        'Copy the data from Sheet1 to the new worksheet
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy Destination:=newWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        
    Next i
    
End Sub

第三次指令 please change your procedure,first get distinct group from column d ,second create sheets for each group then copy header from sheet1 finally move data. 1.先分組 2.建立所有頁面 3.複製標題 4.複製相對資料

Sub MoveData()

    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim groupName As String
    Dim groupNames() As String
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim found As Boolean
    
    'Get last row of data in Sheet1
    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Get distinct group names from column D
    ReDim groupNames(0 To 0)
    groupNames(0) = ThisWorkbook.Worksheets("Sheet1").Cells(2, 4).Value 'Assuming data starts in row 2
    For i = 2 To lastRow
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, 4).Value
        found = False
        For j = 0 To UBound(groupNames)
            If groupName = groupNames(j) Then
                found = True
                Exit For
            End If
        Next j
        If Not found Then
            ReDim Preserve groupNames(0 To UBound(groupNames) + 1)
            groupNames(UBound(groupNames)) = groupName
        End If
    Next i
    
    'Create new worksheet for each group name
    For i = 0 To UBound(groupNames)
        Set newWs = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        newWs.Name = groupNames(i)
        ThisWorkbook.Worksheets("Sheet1").Rows(1).Copy
        newWs.Rows(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next i
    
    'Loop through each row of data in Sheet1 and move to appropriate worksheet
    For i = 2 To lastRow 'Assuming data starts in row 2
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, 4).Value
        Set ws = ThisWorkbook.Worksheets(groupName)
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy Destination:=ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
    
End Sub

before creating a new worksheet check if alread exists

before insert header row clear datas in that sheet

Sub MoveData()

    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim groupName As String
    Dim groupNames() As String
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim found As Boolean
    
    'Get last row of data in Sheet1
    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Get distinct group names from column D
    ReDim groupNames(0 To 0)
    groupNames(0) = ThisWorkbook.Worksheets("Sheet1").Cells(2, 4).Value 'Assuming data starts in row 2
    For i = 2 To lastRow
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, 4).Value
        found = False
        For j = 0 To UBound(groupNames)
            If groupName = groupNames(j) Then
                found = True
                Exit For
            End If
        Next j
        If Not found Then
            ReDim Preserve groupNames(0 To UBound(groupNames) + 1)
            groupNames(UBound(groupNames)) = groupName
        End If
    Next i
    
    'Create new worksheet for each group name if it doesn't already exist
    For i = 0 To UBound(groupNames)
        found = False
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = groupNames(i) Then
                found = True
                Set newWs = ws
                Exit For
            End If
        Next ws
        If Not found Then
            Set newWs = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newWs.Name = groupNames(i)
            newWs.Cells.ClearContents 'Clear any existing data in the new worksheet
            ThisWorkbook.Worksheets("Sheet1").Rows(1).Copy
            newWs.Rows(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next i
    
    'Loop through each row of data in Sheet1 and move to appropriate worksheet
    For i = 2 To lastRow 'Assuming data starts in row 2
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, 4).Value
        Set ws = ThisWorkbook.Worksheets(groupName)
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy Destination:=ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
    
End Sub

prompt to get the group column number before starting

Sub MoveData()

    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim groupName As String
    Dim groupNames() As String
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim found As Boolean
    Dim groupCol As Long
    
    'Prompt user for group column number
    groupCol = Application.InputBox("Enter the column number for the group:", Type:=1)
    
    'Get last row of data in Sheet1
    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Get distinct group names from specified column
    ReDim groupNames(0 To 0)
    groupNames(0) = ThisWorkbook.Worksheets("Sheet1").Cells(2, groupCol).Value 'Assuming data starts in row 2
    For i = 2 To lastRow
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, groupCol).Value
        found = False
        For j = 0 To UBound(groupNames)
            If groupName = groupNames(j) Then
                found = True
                Exit For
            End If
        Next j
        If Not found Then
            ReDim Preserve groupNames(0 To UBound(groupNames) + 1)
            groupNames(UBound(groupNames)) = groupName
        End If
    Next i
    
    'Create new worksheet for each group name if it doesn't already exist
    For i = 0 To UBound(groupNames)
        found = False
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = groupNames(i) Then
                found = True
                Set newWs = ws
                Exit For
            End If
        Next ws
        If Not found Then
            Set newWs = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newWs.Name = groupNames(i)
            newWs.Cells.ClearContents 'Clear any existing data in the new worksheet
            ThisWorkbook.Worksheets("Sheet1").Rows(1).Copy
            newWs.Rows(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next i
    
    'Loop through each row of data in Sheet1 and move to appropriate worksheet
    For i = 2 To lastRow 'Assuming data starts in row 2
        groupName = ThisWorkbook.Worksheets("Sheet1").Cells(i, groupCol).Value
        Set ws = ThisWorkbook.Worksheets(groupName)
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy Destination:=ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
    
End Sub

最終結果與預期需求相符，感想：優點過程中打錯字或是文法不對，chatGPT還是能夠大致了解，感覺語文理解力很強，程式範例庫眾多，基礎語法與程式架構標準化。缺點是流程運行前後邏輯較差，透過子模組切分與流程先後串聯提示可改善。

bing + Chatgpt 4.0 不須指示先按group建立sheet，coding 能力似乎又強化

Sub MoveData()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim groupCol As Long
    Dim sheetName As String
    
    'Delete all sheets except Sheet1
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Sheet1" Then
            ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True
    
    'Move data from Sheet1 to newly inserted sheets based on group
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    groupCol = Application.InputBox("Enter the column number of the group:", "Group Column", Type:=1)
    
    For i = 2 To lastRow
        sheetName = ws.Cells(i, groupCol).Value
        If Not SheetExists(sheetName) Then
            ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetName
            ws.Rows(1).Copy Destination:=ThisWorkbook.Sheets(sheetName).Cells(1, 1)
        End If
        ws.Rows(i).Copy Destination:=ThisWorkbook.Sheets(sheetName).Cells(ThisWorkbook.Sheets(sheetName).Cells(ThisWorkbook.Sheets(sheetName).Rows.Count, 1).End(xlUp).Row + 1, 1)
    Next i
End Sub

Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function
move_data下載