# 自定义EXCEL过程：体积比转换为质量比

Public Sub 体积比to质量比()

Dim CurSum As Double, tmpSum As Double, targetSum As Double, tmpStr As String, c As Range

On Error GoTo theEnd

If IsEmpty(Application.Selection) Then Exit Sub

tmpStr = InputBox("将当前溶剂比例视为体积比,转换成质量比." & vbCrLf & "请输入质量比的总和", "体积比质量比", "100%")

If tmpStr = "" Then Exit Sub

If Right(tmpStr, 1) = "%" Then

targetSum = Val(Left(tmpStr, Len(tmpStr) - 1)) / 100

Else

targetSum = CDbl(tmpStr)

End If

CurSum = Application.WorksheetFunction.Sum(Application.Selection)

'将每份体积乘以密度,得到单个质量,相加得到总质量数

For Each c In Application.Selection

tmpSum = tmpSum + c * GetSolvDensity(c.Offset(0, -1))

Next c

'将每份质量除以总质量,得到质量百分数,再乘以总目标数,得到目标百分比.

For Each c In Application.Selection

c = (c * GetSolvDensity(c.Offset(0, -1))) * targetSum / tmpSum

Next c

theEnd:

End Sub

Private Function GetSolvDensity(SolvName As String) As Double

Select Case UCase(Trim(SolvName))

Case "DMC": GetSolvDensity = 1.0698

Case "EMC": GetSolvDensity = 1.0132

Case "DEC": GetSolvDensity = 0.9747

Case "EC": GetSolvDensity = 1.37

Case "PC": GetSolvDensity = 1.205

Case "FEC": GetSolvDensity = 1.497

Case "FB": GetSolvDensity = 1.024

Case "EA": GetSolvDensity = 0.902

Case "GBL": GetSolvDensity = 1.129

Case "MPC": GetSolvDensity = 0.98

Case "EP": GetSolvDensity = 0.888

Case "MA": GetSolvDensity = 0.93

Case "BC": GetSolvDensity = 1.1442

Case "PA": GetSolvDensity = 0.8878

Case "MP": GetSolvDensity = 0.915

Case "MB": GetSolvDensity = 0.898

Case Else

MsgBox "新溶剂" & UCase(SolvName) & "未在代码中设定密度."

GetSolvDensity = 0

End Select

End Function

http://blog.sciencenet.cn/blog-1213210-1223487.html

## 全部精选博文导读

GMT+8, 2020-6-3 15:12