Question

我编写了以下代码，但没有帮助根据我的要求。代码应该匹配coloumn标题目标工作簿，搜索中的相同列标题源工作簿（工作表），获取其下的所有数据特定列直到行的结尾并将其复制到相同的列下目标工作簿（工作表）中的列标题。这个任务应该执行到目标工作簿中的所有列工作表被填满。

Sub LPN()



Dim CurrentWS As Worksheet
Set CurrentWS = ActiveSheet

 ActiveWorkbook.Sheets("controls").Select


 >I have made a sheet in the main workbook(Rates EMEA CDS PT+FVA.v1.25 Apr 2016.i1.xlsm) known as **controls** , in this sheet I have specified  the path of the workbook(worksheet) that has to be opened and from where the data has to be copied. The name of the cell where the path has been mentioned I named it as GPL 

 Set master = ActiveWorkbook
 GPL = Range("GPL").Value



Workbooks.Open Filename:=GPL
Set GPLfile = ActiveWorkbook
>Open the particular workbook with specified worksheet having .xlsx extension


Dim SourceWS As Worksheet
Set SourceWS = ActiveWorkbook.Worksheets("PNL Attribution")

Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range

Workbooks("Rates EMEA CDS PT+FVA.v1.25 Apr 2016.i1.xlsm").Activate

Dim TargetWS As Worksheet
Set TargetWS = Worksheets("PNL Attribution")

Dim TargetHeader As Range
Set TargetHeader = TargetWS.Range("A10:ZZ10") (The code will look for all the column headings in the source workbook match it with the headings in the target workbook(worksheet) which are not in order.

Dim RealLastRow As Long
Dim SourceCol As Integer

SourceWS.Activate

For Each Cell In TargetHeader
    If Cell.Value <> "" Then
        Set SourceCell = Rows(SourceHeaderRow).Find _
            (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not SourceCell Is Nothing Then
            SourceCol = SourceCell.Column
            RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If RealLastRow > SourceHeaderRow Then
                Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                    SourceCol)).copy
                TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
            End If
        End If
    End If
Next

CurrentWS.Activate

End Sub

Answer 1

您能适应您的任务吗？

Sub Cols_Value_Add_test()
    Set shSour = Worksheets("1")
    Set shDest = Worksheets("2")

    Dim rngSour As Range, rngDest As Range

    Set rngSour = shSour.Cells(3, 2)
    Set rngDest = shDest.Cells(3, 3)

    Dest_Row = rngDest.Row + rngDest.CurrentRegion.Rows.Count

    Cols_Value_Add rngSour, rngDest

End Sub

Sub Cols_Value_Add(rngSour As Range, _
                   rngDest As Range)
    Dim rngDest_Col As Long, rngDest_Col_Max As Long
    Dim shSour_Col As Long

    rngDest_Col_Max = rngDest.CurrentRegion.Columns.Count

    For rngDest_Col = 1 To rngDest_Col_Max
        shSour_Col = shSour_Col_Find(rngDest, rngDest_Col)
        If shSour_Col > 0 Then _
           CopyPaste rngSour, shSour_Col, rngDest, rngDest_Col

    Next
End Sub

Sub CopyPaste(rngSour As Range, _
              shSour_Col As Long, _
              rngDest As Range, _
              rngDest_Col As Long)

    Dim Sour_Row_Max As Long

    Sour_Row_Max = rngSour.CurrentRegion.Row + rngSour.CurrentRegion.Rows.Count - 1

    With shSour
        Set rngSour = .Range(.Cells(rngSour.Row, shSour_Col), _
                             .Cells(Sour_Row_Max, shSour_Col))
    End With

    rngSour.Copy

    rngDest_Col = rngDest.Row + rngDest_Col - 1

    shDest.Cells(Dest_Row, rngDest_Col).PasteSpecial _
            Paste:=xlPasteValues
End Sub

Function shSour_Col_Find(rngDest As Range, _
                         rngDest_Col As Long) _
                         As Long
    Dim sHeader As String, rng As Range

    sHeader = rngDest.Cells(1, rngDest_Col).Value

    Set rng = shSour.Cells.Find(sHeader, , , xlWhole)

    If Not rng Is Nothing Then _
       shSour_Col_Find = rng.Column

End Function

用于匹配目标工作簿中所有coloumn标头（名称）的代码，然后将值从源工作簿复制到目标

1 个答案: