Search code examples
excelvbams-project

Moving data based on headers then copy pasting

I have a code (adapted from a few places), that is operating in one workbook, and works like this. I have a super long list of addresses that are missing from our system (SLIP), but we have them in ANOTHER system (SAP) that we're closing down. Many people are working on this shutdown, and people export different addresses from SAP to be added to the long list. Now, the formats are different in SAP and SLIP, and this code is designed to take exported data from SAP (and pasted into a sheet creatively titled "SAP"), correctly format it for SLIP, then add those addresses to the super long list of addresses. It does this by taking the SAP data, copy pasting it to the correct location based on the name of that columns header in a conversion sheet (also creatively titled, as "CONVERSION"). All the sheets have the same headers and those titles NEVER change, The order can be mixed up in different places. 'House Number' for example, might be in Column A for the SAP sheet, but Column G in the conversion sheet.

Then the code takes all the converted addresses on the conversion sheet and adds them to the bottom of my long list in a separate sheet (which you guessed it, is titled "SLIP"). There are other interim sheets used to concatenate certain values, trim, and proper etc. and then paste accordingly, but they're hidden and they only paste to the conversion sheet NOT my SLIP sheet. The conversion sheet is just that--a midway point between SAP and SLIP where all the data get's laundered so to speak.

Nothing ever gets taken off my super long list, and I've already resigned myself to being unable to prevent duplicates. The issue I'm having is that when I have more than one address to convert from my SAP sheet, the conversion sheet only has the first row after the header from my SAP sheet. Can anyone tell me what I'm doing wrong? It almost does everything I want.

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
Solution

  • I figured out how to work it. I looked again at some other answers on stackoverflow (particularly this one) and modified the code into a bit of a Frankenstein code that is shown below:

    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

    I had to split my code into three distinct sections: a function and two subs. It still won't skip duplicates but it does almost all of what I need it to do.