在 VBA 復制粘貼宏中使用 UDF

Question

在我的工作簿中，有 2 個工作表（Sheet1 和 Sheet2），Sheet1 有一些數據，例如

我正在嘗試將 SERIAL NO.、HS CODE 和 PALLET MMT 列中的數據復制到 Sheet2 的 PROD 列中。 ID、HS 代碼和凈重。 分別。 現在前兩個副本非常簡單，但我遇到的問題是生成 NET WT。 （括號內的兩個數除以1000的乘積）

默認 Sheet2 看起來像：

結果 Sheet2 數據應如下所示：

我弄完了：

Sub Macro1()
'
' Macro1 Macro
'

'
    Cells.Find(What:="SERIAL", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Cells.Find(What:="PROD", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Range("B4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Sheets("Sheet1").Select
    Range("A1").Select
    Cells.Find(What:="CODE", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("C4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
' @@@@@@@@@@ NET WT. ?????? @@@@@@@@@@@@@
End Sub

我還做了一個函數來計算 NET WT。 & 但努力弄清楚如何在我的代碼中使用它而不讓它太復雜

Function netWT(CellRef As String)
    Dim i As Long, Result As String, ch As String
    For i = 1 To Len(CellRef)
        ch = Mid(CellRef, i, 1)
        Result = Result & IIf(ch Like "[0-9]", ch, " ")
    Next i
    Result = Application.Trim(Result)
    netWT = (Split(Result, " ")(1) * Split(Result, " ")(2)) / 1000
End Function

請幫忙。 也歡迎與我不同的方法......它只需要有效地完成工作。

Answer 1

這應該可以...根據需要調整范圍。

Sub PopulateNetWeightColumn()
    Sheets("Sheet2").Activate
    Range("C4").Select
    While Range("C" & ActiveCell.Row) <> ""
        Range("E" & ActiveCell.Row) = CalculateNetWeight(WorksheetFunction.VLookup(Range("C" & ActiveCell.Row), Sheets("Sheet1").Range("B3:G12"), 4, False))
        ActiveCell.Offset(1, 0).Select
    Wend
End Sub
Function CalculateNetWeight(palletString)
    Dim mult_1, mult_2
    palletString = Mid(palletString, InStr(palletString, "(") + 1, 100)
    palletString = Trim(Replace(Replace(Replace(palletString, " ml", ""), " gm", ""), ")", ""))
    mult_1 = CLng(Left(palletString, InStr(palletString, "x") - 1))
    mult_2 = CLng(Replace(palletString, mult_1 & "x", ""))
    CalculateNetWeight = (mult_1 * mult_2) / 1000
End Function