从关闭的工作簿单元格中获取数据类型并相应地改变操作

Question

我正在一个概述表中从许多不同的工作表中收集指标值，该工作表将用于生成 PowerBI 仪表板。

下面是我的代码，我是 vba 的新手，所以它可能不是那么优雅，但可以满足我需要的东西，除了一件事。

这些工作表中的某些指标值是整数，其他指标值具有数据类型百分比。 如果指标表中的值具有数字格式 %，例如"10"格式为 %，则使用我拥有的当前代码将其视为 0,1。我想将这些百分比乘以 100，并在概述表中添加此数字。但是我很难找到如何提取数据类型，如果是百分比，则乘以 100，如果没有百分比，则按原样获取值。有人能帮忙吗？

提前非常感谢 -

Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err.Number <> 0 Then
HasSheet = False
End If
On Error GoTo 0
End Function

Sub CollectMetrics()
Dim id As Integer
Dim Ind As String
Dim MetricName As String
Dim Include1 As String
Dim Include2 As String
Dim Segment As String
Dim file As String
Dim filepath As String
Dim filename As String
Dim s As Boolean
Dim D As Date
Dim MonthNbr As Integer
Set sh1 = Worksheets("Metrics")
Set sh2 = Worksheets("Metadata")

NumRows = sh1.Range("A1", sh1.Range("A1").End(xlDown)).Rows.Count
For id = 2 To NumRows
MetricName = sh1.Range("A" & id).Value
Include1 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
filename = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = sh1.Range("B" & id).Value
file = "='https://xxx/[" & filename & "]" & Segment
filepath = "https://xxx/"

s = HasSheet(filepath, filename, Segment)
If s Then
D = sh1.Range("C" & id).Value
MonthNbr = Month(D)
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("J" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("O" & id).Value = "values updated on " & Format(Now(), "dd-mm-yy")
Else
sh1.Range("O" & id).Value = "sheet available but segment missing"
End If
ElseIf Include2 = "no" Then
sh1.Range("O" & id).Value = "metric set to not yet include"
ElseIf Include1 = "manual" Then
sh1.Range("O" & id).Value = "metric to be manually updated"
End If
Next
MsgBox (" Update completed! ")
End Sub

Answer 1

如果可以选择以"正确的方式"进行，我会尽量避免将百分比乘以 100 并添加百分比符号。

在这种情况下，这不是一个大问题，只是养成良好的习惯更好。 (仅供记录，10%被视为0,1的原因是因为10%0,1。

尽管如此，我们需要一种简单的方法来将其显示为百分比而不是 1 的分数(如果适用)，并且与 Excel 中的许多任务一样，有多种方法可以完成同一件事。

这种方式让我最不费吹灰之力：

Range("B1") = Range("A1") 'copies the value
Range("B1").NumberFormat = Range("A1") .NumberFormat 'copies the number format.

我所做的更改：

• "最干净"的方法是使用一个名为copyNumber的小潜艇，并调整受影响的线路以使用新程序。

• 我整理了缩进 - 这对组织和可读性很重要。

• 我添加了Option Explicit这是在每个模块开头的好主意，以帮助识别疏忽，例如......

• sh1和sh2没有声明为Worksheets，所以我为它们添加了Dim语句 - 但将它们压缩到与带有:冒号的Set语句共享的行上。

我所做的其他更改纯粹是装饰性的，更多的是参考问题，显然，如果您不喜欢这些更改，请不要使用它们。 :-)

• 我摆脱了ElseIf的 - 我不喜欢它们，原因与缩进很重要的原因相同。

• 我用过..用于删除重复代码(如Sh1.和Application.WorksheetFunction.)的结束语句

• 我将变量声明(Dim语句)从"页面"压缩为 3 行。

---

调整后的代码：

Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub copyNumber(rgeSrc As Range, rgeDest As Range)
rgeDest.Value = rgeSrc.Value                ' copy number
rgeDest.NumberFormat = rgeSrc.NumberFormat  ' copy number format
End Sub
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxx/[" & fileName & "]" & Segment
filePath = "https://xxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
copyNumber .Range("D" & id), Range(file & "'!D" & (MonthNbr + 13))
copyNumber .Range("E" & id), Range(file & "'!E" & (MonthNbr + 13))
copyNumber .Range("F" & id), Range(file & "'!F" & (MonthNbr + 13))
copyNumber .Range("G" & id), Range(file & "'!G" & (MonthNbr + 13))
copyNumber .Range("J" & id), Range(file & "'!D" & (MonthNbr + 40))
copyNumber .Range("K" & id), Range(file & "'!E" & (MonthNbr + 40))
copyNumber .Range("L" & id), Range(file & "'!F" & (MonthNbr + 40))
copyNumber .Range("M" & id), Range(file & "'!G" & (MonthNbr + 40))
Range("O" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
Else
Range("O" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("O" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("O" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub

Answer 2

以防万一将来有人在寻找这种方法，这是我使用的最终代码：

Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String, Include3 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Include3 = .VLookup(MetricName, sh2.Range("B2:L100"), 11, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxxx/[" & fileName & "]" & Segment
filePath = "https://xxxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("H" & id).Value = file & "'!B" & (MonthNbr + 13) 'Actuals KPI Index
Select Case sh1.Range("H" & id).Value
Case "R"
sh1.Range("H" & id).Value = "3"
Case "Y"
sh1.Range("H" & id).Value = "2"
Case "G"
sh1.Range("H" & id).Value = "1"
End Select
sh1.Range("I" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("J" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!B" & (MonthNbr + 13) 'YTD KPI Index
Select Case sh1.Range("M" & id).Value
Case "R"
sh1.Range("M" & id).Value = "3"
Case "Y"
sh1.Range("M" & id).Value = "2"
Case "G"
sh1.Range("M" & id).Value = "1"
End Select
Range("N" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
If Include3 = "%" Then              ' multiply with 100 for percentages
sh1.Range("D" & id).Value = (sh1.Range("D" & id).Value) * 100
sh1.Range("E" & id).Value = (sh1.Range("E" & id).Value) * 100
sh1.Range("F" & id).Value = (sh1.Range("F" & id).Value) * 100
sh1.Range("G" & id).Value = (sh1.Range("G" & id).Value) * 100
sh1.Range("I" & id).Value = (sh1.Range("I" & id).Value) * 100
sh1.Range("J" & id).Value = (sh1.Range("J" & id).Value) * 100
sh1.Range("K" & id).Value = (sh1.Range("K" & id).Value) * 100
sh1.Range("L" & id).Value = (sh1.Range("L" & id).Value) * 100
End If
Else
Range("N" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("N" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("N" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub