问宏将4个工作表中的5列复制到新工作表中的5列中

EN

Set NeededColumn = ThisWorkbook.ws.Cells.Find(What:="ColumnName", _
    LookIn:=xlValues, LookAt:=xlPart, _
    after:=Cells(1, 1), MatchCase:=False, SearchFormat:=False)
ColumnNumber = NeededColumn.Column

'Datum:         20.07.17
'Autohr:        Moosli
'Definition:    main
'Parameter:     -
'
Option Explicit

Public Sub main()
    Dim wb As Workbook
    Dim wsDest As Worksheet
    Dim wsSour As Worksheet

    Dim i As Integer
    Dim j As Integer

    Dim intRowHeader As Integer
    Dim intColHeader As Integer
    Dim strSearch As String
    Dim lngLastRowDest As Long
    Dim lngLastRowSour As Long


    Set wb = ActiveWorkbook
    wb.Worksheets.Add

    Set wsDest = ActiveSheet
    wsDest.Move After:=Sheets(wb.Sheets.Count)

    'Write Header in Sheet 5
    wsDest.Cells(1, 1) = "Product"
    wsDest.Cells(1, 2) = "Risk"
    wsDest.Cells(1, 3) = "Type"
    wsDest.Cells(1, 4) = "Devision"
    wsDest.Cells(1, 5) = "Name"



    For i = 1 To 4 'Loop for all Sheets

        Set wsSour = wb.Sheets(i)

        lngLastRowDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row
        lngLastRowSour = wsSour.Range("A" & wsSour.Rows.Count).End(xlUp).Row
        For j = 1 To 5 'Loop for all Col
            strSearch = wsDest.Cells(1, j).Value

            Call getHeaderRowAndCol(wsSour, intRowHeader, intColHeader, strSearch)

            Range(Cells(intRowHeader + 1, intColHeader), Cells(lngLastRowSour, intColHeader)).Select
            Selection.Copy wsDest.Cells(lngLastRowDest + 1, j)


        Next j

    Next i

End Sub


'Datum:         20.07.17
'Autohr:        Moosli
'Definition:    This sub returns Row and Col Index of the Par. strSearch
'Parameter:     ws as Worksheet (Worksheet(Tabelle) in which is Seaching for the Par.)
'               intRowHeader as Integer, Par for storing the Row Nr.
'               intCol as Integer, Par for storing the Col Nr.
'               strSearch as String, what you want to search... ^^

Private Sub getHeaderRowAndCol(ByVal ws As Worksheet, ByRef intRowHeader As Integer, ByRef intCol As Integer, strSearch As String)
 'Get Header Row
    ws.Activate
    ws.Cells(1, 1).Select
    'Zelle wird gesucht
    On Error GoTo Err_Handler2:
    ws.Cells.Find(What:=strSearch, After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlWhole, searchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=True, SearchFormat:=False).Activate
    'Spalte und Zeile werden Ausgelesen
    intRowHeader = ActiveCell.Row
    intCol = ActiveCell.Column
Err_Handler2:
End Sub