Перемещение данных на основе заголовков и копирование вставки

Question

У меня есть код (адаптированный из нескольких мест), который работает в одной книге и работает следующим образом.У меня есть очень длинный список адресов, которые отсутствуют в нашей системе (SLIP), но они есть в другой системе (SAP), которую мы закрываем.Многие люди работают над этим отключением, и люди экспортируют разные адреса из SAP, чтобы добавить их в длинный список.Теперь форматы в SAP и SLIP различны, и этот код предназначен для получения экспортированных данных из SAP (и вставки в лист с креативным названием «SAP»), правильного форматирования для SLIP и добавления этих адресов в супер длинный список.адресов.Это делается путем получения данных SAP и копирования их в правильное местоположение на основе имени заголовка этого столбца в листе преобразования (также с креативным названием «КОНВЕРСИЯ»).Все листы имеют одинаковые заголовки, и эти заголовки НИКОГДА не меняются. Порядок может быть перепутан в разных местах.Например, «Номер дома» может быть в столбце A для листа SAP, а в столбце G - в листе преобразования.

Затем код берет все преобразованные адреса на листе преобразования и добавляет их в конец моего длинного списка на отдельном листе (который, как вы уже догадались, называется «SLIP»).Существуют и другие промежуточные листы, используемые для объединения определенных значений, обрезки, правильности и т. Д., А затем вставки соответствующим образом, но они скрыты и вставляются только в конверсионный лист, а НЕ в мой лист 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

Answer 1

Я понял, как это работает.Я снова посмотрел на некоторые другие ответы на stackoverflow (в частности, этот ) и изменил код в немного кода Франкенштейна, который показан ниже:

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

Мне пришлось разделить мойкод на три отдельных раздела: функция и два подпрограммы.Он по-прежнему не пропускает дубликаты, но выполняет почти все, что мне нужно.