mapping column headers from one sheet to another

问题

i wanted to map columns from one worksheet to another and this is the code i have tried:

Dim x As Integer
x = 2
Do Until Sheets("Sheet1").Range("A" & x).Value = ""
Sheets("Sheet2").Range("C" & x).Value = Sheets("Sheet1").Range("A" & x).Value
x = x + 1
Loop
x = 2
Do Until Sheets("Sheet1").Range("B" & x).Value = ""
Sheets("Sheet2").Range("A" & x).Value = Sheets("Sheet1").Range("B" & x).Value
x = x + 1
Loop
x = 2
Do Until Sheets("Sheet1").Range("C" & x).Value = ""
Sheets("Sheet2").Range("B" & x).Value = Sheets("Sheet1").Range("C" & x).Value
x = x + 1
Loop

in worksheet1 i have:

  A                 B            C 
1 applicationname applicationid number 
2 applcation1          1          123 
3 applcation2          2          454 
4 applcation3          3          897

in worksheet2 i got:

  A                 B            C 
1  appid           num        appname              
2   1              123        applcation1          
3   2              454        applcation2          
4   3              897        applcation3 

the problem is there are many other columns and this code seems to be lengthy..i need to loop so that applicationid maps to appid and so on ..i want to know wether there is a way to map columns based on the headers(the data in first row) and can anyone please say what to do if i want to copy the empty cells also? may i know wether i can have an worksheet like interface say sheet3 where i can fill the required mappings like

     A                       B
 1   Application Name        App Name
 2   Application ID          AppID
 3   Technology              Tech
 4   Business Criticality    Bus Criticality
 5   IT Owner                IT Owner
 6   Business Owner    BusOwner                                                            and accordingly map them?thanks in advance

回答1:

Try this:

Sub Map()

    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim HeadersOne() As String
    Dim HeadersTwo() As String

    With ThisWorkbook
        Set Sh1 = .Sheets("Sheet1") 'Modify as necessary.
        Set Sh2 = .Sheets("Sheet2") 'Modify as necessary.
    End With

    HeadersOne() = Split("applicationname,applicationid,number", ",")
    HeadersTwo() = Split("appname,appid,num", ",")

    For HeaderIter = 1 To 3
        SCol = GetColMatched(Sh1, HeadersOne(HeaderIter - 1))
        TCol = GetColMatched(Sh2, HeadersTwo(HeaderIter - 1))
        LRow = GetLastRowMatched(Sh1, HeadersOne(HeaderIter - 1))

        For Iter = 2 To LRow
            Sh2.Cells(Iter, TCol).Value = Sh1.Cells(Iter, SCol).Value
        Next Iter
    Next HeaderIter

End Sub

Function GetLastRowMatched(Sh As Worksheet, Header As String) As Long
    ColIndex = Application.Match(Header, Sh.Rows(1), 0)
    GetLastRowMatched = Sh.Cells(Rows.Count, ColIndex).End(xlUp).Row
End Function

Function GetColMatched(Sh As Worksheet, Header As String) As Long
    ColIndex = Application.Match(Header, Sh.Rows(1), 0)
    GetColMatched = ColIndex
End Function

Let us know if this helps.

Follow-up Edit:

Here's a way to set up an interface.

Assuming that your set-up is similar to mine...

Sheet1:

Sheet2 (I jumbled the headers on purpose):

Interface Sheet:

Result after running code:

Here's the code. Modify accordingly and make sure your headers are exact.

Sub ModdedMap()

    Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
    Dim HeadersOne As Range, HeadersTwo As Range
    Dim hCell As Range

    With ThisWorkbook
        Set Sh1 = .Sheets("Sheet1") 'Modify as necessary.
        Set Sh2 = .Sheets("Sheet2") 'Modify as necessary.
        Set Sh3 = .Sheets("Interface") 'Modify as necessary.
    End With

    Set HeadersOne = Sh3.Range("A1:A" & Sh3.Range("A" & Rows.Count).End(xlUp).Row)

    Application.ScreenUpdating = False

    For Each hCell In HeadersOne

        SCol = GetColMatched(Sh1, hCell.Value)
        TCol = GetColMatched(Sh2, hCell.Offset(0, 1).Value)
        LRow = GetLastRowMatched(Sh1, hCell.Value)

        For Iter = 2 To LRow
            Sh2.Cells(Iter, TCol).Value = Sh1.Cells(Iter, SCol).Value
        Next Iter

    Next hCell

    Application.ScreenUpdating = True

End Sub

Function GetLastRowMatched(Sh As Worksheet, Header As String) As Long
    ColIndex = Application.Match(Header, Sh.Rows(1), 0)
    GetLastRowMatched = Sh.Cells(Rows.Count, ColIndex).End(xlUp).Row
End Function

Function GetColMatched(Sh As Worksheet, Header As String) As Long
    ColIndex = Application.Match(Header, Sh.Rows(1), 0)
    GetColMatched = ColIndex
End Function

回答2:

There's no need in this situation to copy the cells one at a time. Not for any performance reason (unless you have tons and tons of data you probably wouldn't run into any performance issues) - it's just that the code would be simpler if you copied the columns directly from Sheet1 to Sheet2 in one operation per column.

The first step is to identify how many rows total are in Sheet1 that you want to copy. There are many schools of thought on how to obtain a used row count in Excel, but the simplest is probably to use the expression UsedRange.Rows.Count on the worksheet (we subtract 1 because we're not copying the header row):

Dim row_count As Long

row_count = Sheets("Sheet1").UsedRange.Rows.Count - 1
Range("Sheet1!A2").Resize(row_count).Copy Range("Sheet2!C2")
Range("Sheet1!B2").Resize(row_count).Copy Range("Sheet2!A2")
Range("Sheet1!C2").Resize(row_count).Copy Range("Sheet2!B2")

I would be satisfied doing it this way, with one line per column that you want to copy. There's still duplicated code, but it's manageable in my opinion.

来源：https://stackoverflow.com/questions/21130328/mapping-column-headers-from-one-sheet-to-another