VBA Code overwrites existing data.

Question

The following procedures are designed to take data in the first column and data in the second column and make unique records for every possible combination---on another worksheet. They are very much the same, they simply use two different sets of input columns and separate worksheets to which they paste. So data entered as:

a.....abc

b.....def

........ghi

........jkl

Would create the following records:

a.....abc

a.....def

a.....ghi

a.....jkl

b.....abc

b.....def

b.....ghi

b.....jkl

Code 1, below, never overwrites any existing data, and it should not. It works great.

CODE 1:

Sub CustomChoices()

Dim ws1 As Worksheet, ws2 As Worksheet

Dim rA As Long, rB As Long, r As Long, N As Long, i As Integer

Set ws1 = Sheets("CustomChoiceSets")

Set ws2 = Sheets("ChoicesData")

Application.ScreenUpdating = False

rA = ws1.Cells(Rows.Count, "A").End(xlUp).Row

rB = ws1.Cells(Rows.Count, "B").End(xlUp).Row

r = ws2.Cells(Rows.Count, "A").End(xlUp).Row

If ws2.Range("A1") = "" Then N = 1 Else: N = r + 1

For i = 2 To rA

ws1.Cells(i, 1).Copy

ws2.Cells(N, 1).Resize(rB - 1).PasteSpecial xlValues

ws1.Range("B2:B" & rB).Copy

ws2.Cells(N, 2).PasteSpecial xlValues

N = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1

Next i

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

Code 2, below, often overwrite existing data. It sometimes puts one set of the "pasted" data at the top, overwriting existing data, and other sets of the "pasted data" at the bottom, which is where all sets should go.

Sub CustomMapping()

Dim ws3 As Worksheet, ws4 As Worksheet

Dim rD As Long, rE As Long, r As Long, N As Long, i As Integer

Set ws3 = Sheets("CustomChoiceSets")

Set ws4 = Sheets("ChoiceMaps")

Application.ScreenUpdating = False

rD = ws3.Cells(Rows.Count, "D").End(xlUp).Row

rE = ws3.Cells(Rows.Count, "E").End(xlUp).Row

r = ws4.Cells(Rows.Count, "D").End(xlUp).Row

If ws4.Range("D1") = "" Then N = 1 Else: N = r + 1

For i = 2 To rD

ws3.Cells(i, 4).Copy

'ws3.Cells(i, 1).Copy

ws4.Cells(N, 1).Resize(rE - 1).PasteSpecial xlValues

ws3.Range("E2:E" & rE).Copy

ws4.Cells(N, 2).PasteSpecial xlValues

N = ws4.Cells(Rows.Count, "A").End(xlUp).Row + 1

Next i

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

Any help or error handling you can give is greatly appreciated!

If anyone needs to see the file, let me know, and I'll email it with data.

Answer 1

Hi,

try this code..

(make a copy before..)

Sub CustomMapping()

Dim ws3 As Worksheet, ws4 As Worksheet

Dim rD As Long, rE As Long, r As Long, N As Long, i As Integer

Set ws3 = Sheets("CustomChoiceSets")

Set ws4 = Sheets("ChoiceMaps")

Application.ScreenUpdating = False

rD = ws3.Cells(Rows.Count, "D").End(xlUp).Row

rE = ws3.Cells(Rows.Count, "E").End(xlUp).Row

r = ws4.Cells(Rows.Count, "D").End(xlUp).Row

For i = 2 To rD

N = ws4.Cells(Rows.Count, "A").End(xlUp).Row + 1

ws3.Cells(i, 4).Copy

ws4.Cells(N, 1).Resize(rE - 1).PasteSpecial xlValues

ws3.Range("E2:E" & rE).Copy

ws4.Cells(N, 2).PasteSpecial xlValues

Next i

Application.CutCopyMode = False

If ws4.[a1] = "" Then

ws4.[a1].Delete shift:=xlUp

ws4.[b1].Delete shift:=xlUp

End If

Application.ScreenUpdating = True

End Sub

Answer 2

It's perfect. No complaints. :)

I am adding a new question, too. LOL

Thanks again!!

Answer 3

TasosK, thanks so much AGAIN!! I have distributed the app with this code, and am keeping my fingers crossed. It seems the issue I had was intermittent, only problem with certain workbooks. Very strange.

Anyway, I suspect it will work. I will certainly mark your answer in a few days. :)

I have a new question, too! I am posting it now.