分類: Excel

在 Excel 2010 中建立並使用自訂列表進行排序，可用於樞紐分析

1.點擊檔案=>點擊左側欄的選項=>在 Excel 選項 視窗中，從左側窗格選擇進階=>一般，然後點擊編輯自訂列表按鈕。
在 自訂列表 對話框中：在列表項目」框中，輸入您的自訂順序，每項一行
點擊 新增 以儲存列表。該列表將出現在左側的「自訂列表」框中。
點擊 確定 關閉 自訂列表 對話框，再點擊 確定 退出 Excel 選項。

2.將自訂列表排序應用於樞紐分析表：
點擊樞紐分析表內的任意位置以啟動它。
點擊樞紐分析表中欄位標籤旁的下拉箭頭。
選擇 排序 > 更多排序選項。在 排序 對話框中：
選擇 升序 (A 到 Z) 或 降序 (Z 到 A)（升序將遵循您的自訂列表順序；降序將反轉它）。
取消勾選「每次更新報表時自動排序」（若已勾選）。
在「第一個鍵排序順序」下，從下拉選單中選擇您的自訂列表。
點擊 確定，然後再次點擊確定以應用排序。

使用Office 2003開啟Office 2007格式的Word、Excel檔案，出現 “轉換程式無法儲存檔案” 訊息

可能是檔案格式相容性套件FileFormatConverters版本較舊，在網路搜尋找到軟體王下載連結。先移除舊版，安裝新版後，可正常開啟。

小版本差異如下圖

Excel Delete Rows Based On Criteria以巨集刪除特定條件之資料，如某欄資料空白

Sub DeleteRowsBasedOnCriteria()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim deleteFlag As Boolean
    Dim concatenateString As String

    ' Set the active sheet as the worksheet
    Set ws = ActiveSheet

    ' Find the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' First pass: Mark rows for deletion based on the first criteria
    For i = lastRow To 1 Step -1
        ' Initialize deleteFlag to False for each row
        deleteFlag = False

        ' Check if any of the columns A through H is empty
        For j = 1 To 8 ' Columns A through H
            If ws.Cells(i, j).Value = "" Then
                ' Set the deleteFlag to True if any column is empty
                deleteFlag = True
                Exit For
            End If
        Next j

        

        ' Delete the entire row if any column A through H is empty or if the concatenation matches
        If deleteFlag Then
            ws.Rows(i).Delete
        End If
    Next i

    ' Find the last row again after the first deletion
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Second pass: Delete rows based on the second criteria
    For i = lastRow To 1 Step -1
        ' Check if the concatenation of the first 9 columns equals a specific string
        concatenateString = ""
        For j = 1 To 9 ' Columns A through I
            concatenateString = concatenateString & ws.Cells(i, j).Value
        Next j

        ' Delete the entire row if the concatenation matches the specific string
        If concatenateString = "訂單號碼訂單日預定出港日品名台灣品名數量/KGS包裝方式目的地備註" Then
            ws.Rows(i).Delete
        End If
    Next i
End Sub

在Excel 2013 檔案中，點選滑鼠右鍵，未出現右鍵功能選單，但在其他程式Word、Outlook皆正常(right-click menu is missing in excel)

1.在工作表的地方按 ALT + F11

2.再按 Ctrl+G 會出現一欄及時運算

3.複製貼上以下程式碼

Application.CommandBars(“Cell”).enabled=True

Application.CommandBars(“Cell”).Reset

4.按Enter

5.按 Alt+Q 回到工作表

https://groups.google.com/g/microsoft.public.excel.misc/c/rlvcJrM_JE8?pli=1

Right Click on Column or Row does not show Context Menu

application.CommandBars(“Cell”).Reset
application.CommandBars(“cell”).Enabled = True
application.CommandBars(“Column”).Reset
application.CommandBars(“column”).Enabled = True
application.CommandBars(“Row”).Reset
application.CommandBars(“row”).Enabled = True

press enter every command

https://superuser.com/questions/360399/right-click-on-column-or-row-does-not-show-context-menu

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

EXCEL分欄列印–一頁印原兩頁資料

Step1.首先選取Excel中要列印的部分，並按下功能表的【編輯】→【複製】。
Step2.開啟Word程式，打開一個新文件後，按下功能表的【編輯】→【貼上】。
Step3.貼上從Excel複製過來的欄位內容後，繼續在Word裡點選功能表的【格式】→【欄】。
Step4.在「欄」對話盒裡，選取要分割的欄位數量後，按下〔確定〕。
Step5.接著選取第一列，並按下功能表的【表格】→【跨頁標題重複】。
Step6.最後可以看到Word中的每一欄表頭，都會出現標題列，這樣就能把Excel裡的資料做分欄列印了。

測試使用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下載

自動彙整資料夾下所有Excel檔案資料到該檔案並增加計算欄位

Sub CombineExcelFilesFirstSheetExceptFirstRow()
Dim Path As String, Filename As String, Sheet As Worksheet, LastRow As Long, i As Integer, cFilename As String
Dim wb As Workbook, DestSheet As Worksheet, LastDestRow As Long, Owb As Workbook
ClearAllRowsExceptFirst
Application.ScreenUpdating = False
Application.CutCopyMode = False
‘ Get the path of the folder that contains the current workbook
Path = ThisWorkbook.Path & “\”
Set Owb = ActiveWorkbook
‘ Loop through all the Excel files in the folder
Filename = Dir(Path & “.xlsx“)
cFilename = ThisWorkbook.Name
Do While Filename <> “”
‘ Exclude the current workbook from the merge
If Filename <> cFilename Then
‘ Open each Excel file in the folder
Set wb = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
‘ Copy the data from the first worksheet of the Excel file, excluding the first row
With wb.Sheets(1)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
.Range(“A2”).Resize(LastRow – 1, .UsedRange.Columns.Count).Copy Destination:=Owb.ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Offset(1, 0)
End If
End With
‘ Close the Excel file
wb.Close
End If
‘ Move to the next Excel file in the folder
Filename = Dir()
Loop
‘ Adjust the column widths in the current worksheet
‘For i = 1 To ActiveSheet.Columns.Count
‘ ActiveSheet.Columns(i).AutoFit
‘Next i
AddConditionalFormulaToColumn
Application.ScreenUpdating = True
Application.CutCopyMode = True
End Sub

Sub ClearAllRowsExceptFirst()
With ActiveSheet
.Range(“A2:” & .Cells(.Rows.Count, .Columns.Count).Address).ClearContents
End With
End Sub

Sub AddConditionalFormulaToColumn()
Dim lastRow As Long
lastRow = Cells(Rows.Count, “A”).End(xlUp).Row ‘ Assumes data is in column A
Range(“U2:U” & lastRow).Formula = “=ROUND(IF(L2=””三聯式””,R2+S2,R2)*IF(B2=””STW0192″”,0.5,1),0)”
‘ Alternatively, you can use the FormulaR1C1 property to add the formula
‘ in R1C1 notation:
‘Range(“C2:C” & lastRow).FormulaR1C1 = “=IF(RC[-1]=””STW0192″”,0.5,1)”
End Sub

Excel Button Click with ERROR handler

Sub 按鈕1_Click()
‘On Error Resume Next
On Error GoTo MyErrorHandler:
s_line = Cells(1, 8)
e_line = Cells(1, 9)
If Not IsNumeric(s_line) Then
MsgBox (“請輸入數字”)
End
End If
If Not IsNumeric(e_line) Then
MsgBox (“請輸入數字”)
End
End If
If s_line > e_line Then
MsgBox (“請輸入正確起訖”)
End
End If
If e_line – s_line > 4 Then
MsgBox (“最多輸入5筆資料”)
End
End If
Range(“C5:F9”).Value = “”

For i = 1 To e_line - s_line + 1
    'Cells(4 + i, 3).Value = Worksheets("shipment").Cells(s_line + i - 1, 14).Value
    Cells(4 + i, 3).Value = Application.WorksheetFunction.VLookup(Worksheets("shipment").Cells(s_line + i - 1, 6).Value, Worksheets("item_ref").Range("A:E"), 2, False)
    Cells(4 + i, 5).Value = Worksheets("shipment").Cells(s_line + i - 1, 7).Value
    Cells(4 + i, 6).Value = Worksheets("shipment").Cells(s_line + i - 1, 9).Value
Next i

Exit Sub

MyErrorHandler:
If Err.Number = 1004 Then
MsgBox “第” & CStr(s_line + i – 1) & “行無參照品名”
Resume Next
ElseIf Err.Number = 13 Then
MsgBox “You have entered an invalid value.”
End If

End Sub

自訂 IsInt函數 檢查是否是整數

Function IsInt(aValue as Variant) As Boolean
    On Error Resume Next
    IsInt = (CInt(aValue) = aValue)
    On Error Goto 0
End Function