Question

我附加了映射表的图像，并根据我创建的映射表编写了这两个函数:(表名为“Automation”）

1）

Function GetRow(rowName As String) As String
Dim refRange As Range: Set refRange = Sheet14.Range("Automation")
On Error GoTo errProc
GetRow = WorksheetFunction.VLookup(rowName, refRange, 2, 0)


Exit Function


errProc:
If Err.Number = 1004 Then
Err.Raise "5000", "Something bad happened", "Value " & rowName & " not 
found!!"
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If


End Function

2）

Function GetMap(rowName As String) As String
Dim refRange As Range: Set refRange = Sheet14.Range("Automation")
On Error GoTo errProc
GetMap = WorksheetFunction.VLookup(rowName, refRange, 1, 0)

Exit Function

errProc:
If Err.Number = 1004 Then
Err.Raise "5000", "Something bad happened", "Value " & rowName & " not 
found!!"
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If

End Function

这是整个更新的代码：

Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks:=False, Transpose:=False

Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% 
completed"
DoEvents
End Sub

Sub Header()


DestName = "Data Cost Estimate"              'Name of destination sheet
SourceName = "EST Actuals"                   'Name of Source sheet                                              
MyDir = "\Path\"            'Default directory path"
Const steps = 22            'Number of rows copied
ref = 13              'row in Estimate sheet in which 'Grand Total' is 
present

Set Wb = ThisWorkbook

' disable certain excel features to speed up the process


Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual

MyFile = Dir(MyDir & "Estimate.xlsm")    'change file extension
ChDir MyDir

Set wkb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)

Dim lnCol As Long
Dim last As Long  'Find the last non-blank cell in row 1
lnCol = wkb.Sheets(SourceName).Cells(ref, 
Columns.Count).End(xlToLeft).Column

last = lnCol - 1
MsgBox "Last but one column is: " & last

Dim from, dest As String
from = GetRow(GetMap(wkb.Sheets(SourceName)))         
j = Wb.Sheets(DestName).Cells(1, 1).EntireColumn.Find(What:=from, 
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, 
SearchDirection:=xlNext, MatchCase:=False).Row


Call CopyRange(Sheets(SourceName).Range("C18:R18"), 
 Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C20:R20"), 
 Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C27:R27"), 
Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

wkb.Close

 MyFile = Dir()

 'Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 'Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 ActiveSheet.DisplayPageBreaks = True

当我尝试代码时，我得到一个错误，说“对象不支持此属性”，我希望函数返回一个值。我无法弄清楚如何纠正这个问题。 CopyRange是我用于进度条的另一个子组。

Answer 1

经过大量的试验和错误以及@tomjohnriddle的帮助，这里是函数和正确的代码：

1）功能：

 Function GetSourceKey(destinationKey As String) As String
 Dim refRange As Range: Set refRange = Sheet14.Range("Mapping table name")
 On Error GoTo errProc
 GetSourceKey = WorksheetFunction.VLookup(destinationKey, 
 ThisWorkbook.Sheets("Sheet name in which mapping table is present").[Mapping table name], 2, 0)

Exit Function

errProc:
 If Err.Number = 1004 Then
 Err.Raise "5000", "Something bad happened", "Value " & destinationKey & " 
 not found!!"
 Else
 Err.Raise Err.Number, Err.Source, Err.Description
  End If

  End Function

2）代码：

   Option Explicit

   Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
   fromRange.Copy
   toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
   SkipBlanks:=False, Transpose:=False

   Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% 
   completed"
   DoEvents
    End Sub

    Sub Header()

    DestName = "x"    'Name of destination sheet
    SourceName = "y"             'Name of Source sheet
    MyDir = "\Path\"              'Default directory path"
    Const steps = 22              'Number of rows copied
    ref = 13      'row in Estimate sheet in which 'Grand Total' is present

    Set DestWb = ThisWorkbook            'Setting Destination workbook

    Dim DestSheet As Worksheet
    Dim SrcSheet As Worksheet


    ' disable certain excel features to speed up the process    

    Application.DisplayAlerts = False
    'Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

        MyFile = Dir(MyDir & "Estimate*.xls*")    'change file extension
        ChDir MyDir

        Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)

        completed = 0
        Application.StatusBar = "Copying In progress..." & Round(completed, 
        0) & "% completed"


        'Find the last non-blank cell in row ref
        lnCol = SrcWb.Sheets(SourceName).Cells(ref, 
        Columns.Count).End(xlToLeft).Column

        last = lnCol - 1                        'To get penultimate column


        Set DestSheet = DestWb.Sheets(DestName)
        Set SrcSheet = SrcWb.Sheets(SourceName)

        destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row            'Finding last non-blank cell in Column 1 in Destination sheet
        MsgBox "Last row is: " & destTotalRows


        For i = 1 To destTotalRows

            destKey = DestSheet.Cells(i, 1)
            If destKey = "" Then GoTo endFor

            sourceKey = GetSourceKey(destKey)
            If sourceKey = "" Then GoTo endFor

            Debug.Print "DestKey", destKey, "SourceKey", sourceKey

            k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
            j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row

            Debug.Print j, k

            Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed)
            completed = completed + (100 / steps)
   endFor:
        Next i

        SrcWb.Close


        Application.StatusBar = "Copying is complete"


  DoEvents

  MyFile = Dir()

    Dim x As Long
    'Find the last non-blank cell in row 1
        DestColCount = Cells(1, Columns.Count).End(xlToLeft).Column

        DestWb.Sheets(DestName).Columns(2).Copy
            For x = 3 To DestColCount
                Columns(x).PasteSpecial Paste:=xlPasteFormats
            Next


   'Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ActiveSheet.DisplayPageBreaks = True

    End Sub

行标题映射到粘贴数据

1 个答案: