根据标题移动数据，然后复制粘贴

时间：2018-05-25 19:20:01

标签： excel excel-vba microsoft-project-vba vba

我有一个代码（改编自几个地方），它在一个工作簿中运行，并且像这样工作。我有一个超长的地址列表，我们的系统（SLIP）中缺少这些地址，但是我们将它们放在我们关闭的另一个系统（SAP）中。许多人正在进行此关闭，人们从SAP导出不同的地址以添加到长列表中。现在，SAP和SLIP中的格式不同，此代码旨在从SAP获取导出的数据（并粘贴到创造性地标题为＆＃34; SAP＆＃34;的表格中），正确格式化为SLIP，然后添加这些地址到超长的地址列表。它通过获取SAP数据，根据转换表中该列标题的名称将其粘贴到正确的位置（也创造性地标题为＆＃34; CONVERSION＆＃34;）来实现此目的。所有工作表都有相同的标题，这些标题永远不会改变，订单可以在不同的地方混合。 ＆＃39;门牌号码＆＃39;例如，可能在SAP表的A列中，但在转换表中可能是G列。

然后代码获取转换表上的所有转换后的地址，并将它们添加到我的长列表底部的单独表格中（您猜对了，标题为＃34; SLIP＆＃34;）。还有其他临时表用于连接某些值，修剪和正确等，然后相应地粘贴，但它们被隐藏，它们只粘贴到转换表而不是我的SLIP表。转换表就是这样 - SAP和SLIP之间的中间点，可以说所有数据都被清洗了。

我的超长名单中没有任何东西被取消，我已经因为无法防止重复而辞职了。我遇到的问题是，当我从SAP工作表转换多个地址时，转换表只有SAP工作表标题后面的第一行。谁能告诉我我做错了什么？它几乎可以完成我想要的一切。

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

1 个答案:

答案 0 :(得分：1)

我想出了如何使用它。我再次查看了stackoverflow上的其他一些答案（特别是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

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

相关问题
最新问题