根据 headers 移动数据然后复制粘贴

Question

我有一个代码（改编自几个地方），它在一个工作簿中运行，并且像这样工作。我有一个超长的地址列表，我们的系统 (SLIP) 中缺少这些地址，但我们在另一个我们正在关闭的系统 (SAP) 中有它们。很多人都在为这次停工而努力，人们从 SAP 中导出不同的地址以添加到长列表中。现在，SAP 和 SLIP 中的格式不同，此代码旨在从 SAP 中获取导出的数据（并粘贴到 sheet 创造性地命名为 "SAP"），为 SLIP 正确格式化，然后添加那些地址到超长地址列表。它通过获取 SAP 数据，根据转换 sheet 中的列名称 header（也有创意地命名为 "CONVERSION"）将其复制粘贴到正确位置来实现。所有 sheets 都有相同的 headers 并且那些标题永远不会改变，顺序可以在不同的地方混淆。 'House Number' 例如，可能在 SAP sheet 的列 A 中，但在转换 sheet 中的列 G。

然后代码在转换 sheet 中获取所有转换后的地址，并将它们添加到我的长列表的底部，单独 sheet （你猜对了，标题为 "SLIP").还有其他临时 sheets 用于连接某些值，trim 和适当的等，然后相应地粘贴，但它们是隐藏的，它们只粘贴到转换 sheet 不是我的滑动 sheet。转换 sheet 就是 SAP 和 SLIP 之间的中间点，可以说所有数据都在这里被清洗。

没有任何东西可以从我的超长列表中删除，而且我已经听天由命于无法防止重复。我遇到的问题是，当我有多个地址要从我的 SAP sheet 转换时，转换 sheet 仅在我的 SAP [=] header 之后的第一行24=]。谁能告诉我我做错了什么？它几乎可以满足我的所有需求。

Sub convertmelikeoneofyourfrenchgirls()

Dim ShtOne As Worksheet: Set ShtOne = Sheets("CONVERSION")
Dim ShtTwo As Worksheet: Set ShtTwo = Sheets("SAP")
Dim shtOneHead As Range, shtTwoHead As Range
Dim headerOne As Range, headerTwo As Range
Dim abrv As Worksheet: Set abrv = Sheets("ABRV")
Dim slip As Worksheet: Set slip = Sheets("SLIP")
Dim ads As Worksheet: Set ads = Sheets("ADS")
Dim adsrng As Range: Set adsrng = ads.Range("B:B")
Dim atlas As Worksheet: Set atlas = Sheets("ATLAS")
Dim atlasrng As Range: Set atlasrng = atlas.Range("b:b")
Dim conatlas As Range: Set conatlas = ShtOne.Range("y:y")
Dim conads As Range: Set conads = ShtOne.Range("W:W")
Dim dis As Worksheet: Set dis = Sheets("DIS")
Dim abrv2 As Worksheet: Set abrv2 = Sheets("abrv2")
Dim FndList2, FndList, FndList3, x&

Dim lastCol As Long

'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))

'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))

'actually loop through and find values
For Each headerTwo In shtTwoHead
    For Each headerOne In shtOneHead
        If headerTwo.Value = headerOne.Value Then
            headerOne.Offset(1, 0).Value = headerTwo.Offset(1, 0).Value
        End If
    Next headerOne
Next headerTwo


adsrng.Copy
conads.PasteSpecial xlPasteValues

atlasrng.Copy
conatlas.PasteSpecial xlPasteValues

FndList = abrv.Cells(1, 1).CurrentRegion

For x = 1 To UBound(FndList)
    ShtOne.Range("n:n").Replace what:=FndList(x, 1), Replacement:=FndList(x, 2), LookAt:=xlWhole, MatchCase:=True
Next

FndList2 = dis.Cells(1, 1).CurrentRegion

For x = 1 To UBound(FndList2)
    ShtOne.Range("b:b").Replace what:=FndList2(x, 1), Replacement:=FndList2(x, 2), LookAt:=xlWhole, MatchCase:=True
Next

FndList3 = abrv2.Cells(1, 1).CurrentRegion

For x = 1 To UBound(FndList3)
    ShtOne.Range("x:x").Replace what:=FndList3(x, 1), Replacement:=FndList3(x, 2), LookAt:=xlWhole, MatchCase:=True
Next

Dim DestinationStartingCell As Range
Dim SheetRowCount As Long

Worksheets("CONVERSION").Range("A2:Z100").Copy

SheetRowCount = Worksheets("SLIP").Rows.Count '1048576 for Excel 2007 and later
Set DestinationStartingCell = Worksheets("SLIP") _
 .Range("A" & SheetRowCount).End(xlUp).Offset(1, 0)
DestinationStartingCell.PasteSpecial xlPasteValues

Application.CutCopyMode = False
slip.Select

End Sub

Answer 1

我想出了如何使用它。我再次查看了 Whosebug 上的一些其他答案（特别是 this one）并将代码修改为如下所示的 Frankenstein 代码：

Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("CONVERSION").Range("A1:AZ1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("SAP").Range("A1:AZ1")

For Each header In headers
    If GetHeaderColumn(header.Value) > 0 Then
        Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("CONVERSION").Cells(2, GetHeaderColumn(header.Value))
    End If
Next
Call CONTINUE
End Sub

Sub CONTINUE()
Dim ShtOne As Worksheet: Set ShtOne = Sheets("CONVERSION")
Dim ShtTwo As Worksheet: Set ShtTwo = Sheets("SAP")
Dim shtOneHead As Range, shtTwoHead As Range
Dim headerOne As Range, headerTwo As Range
Dim abrv As Worksheet: Set abrv = Sheets("ABRV")
Dim slip As Worksheet: Set slip = Sheets("SLIP")
Dim ads As Worksheet: Set ads = Sheets("ADS")
Dim adsrng As Range: Set adsrng = ads.Range("B:B")
Dim atlas As Worksheet: Set atlas = Sheets("ATLAS")
Dim atlasrng As Range: Set atlasrng = atlas.Range("b:b")
Dim conatlas As Range: Set conatlas = ShtOne.Range("y:y")
Dim conads As Range: Set conads = ShtOne.Range("W:W")
Dim dis As Worksheet: Set dis = Sheets("DIS")
Dim abrv2 As Worksheet: Set abrv2 = Sheets("abrv2")
Dim FndList2, FndList, FndList3, x&

adsrng.Copy
conads.PasteSpecial xlPasteValues

atlasrng.Copy
conatlas.PasteSpecial xlPasteValues

FndList = abrv.Cells(1, 1).CurrentRegion

For x = 1 To UBound(FndList)
    ShtOne.Range("n:n").Replace what:=FndList(x, 1), Replacement:=FndList(x, 2), LookAt:=xlWhole, MatchCase:=True
Next

FndList2 = dis.Cells(1, 1).CurrentRegion

For x = 1 To UBound(FndList2)
    ShtOne.Range("b:b").Replace what:=FndList2(x, 1), Replacement:=FndList2(x, 2), LookAt:=xlWhole, MatchCase:=True
Next

FndList3 = abrv2.Cells(1, 1).CurrentRegion

For x = 1 To UBound(FndList3)
    ShtOne.Range("x:x").Replace what:=FndList3(x, 1), Replacement:=FndList3(x, 2), LookAt:=xlWhole, MatchCase:=True
Next

Dim DestinationStartingCell As Range
Dim SheetRowCount As Long

Worksheets("CONVERSION").Range("A2:Z100").Copy

SheetRowCount = Worksheets("SLIP").Rows.Count '1048576 for Excel 2007 and later
Set DestinationStartingCell = Worksheets("SLIP") _
 .Range("A" & SheetRowCount).End(xlUp).Offset(1, 0)
DestinationStartingCell.PasteSpecial xlPasteValues

Application.CutCopyMode = False
slip.Select

End Sub

我不得不将我的代码分成三个不同的部分：一个函数和两个子函数。它仍然不会跳过重复项，但它几乎完成了我需要它做的所有事情。

根据 headers 移动数据然后复制粘贴

Moving data based on headers then copy pasting

excel

vba

ms-project