PDA

View Full Version : Sleeper: Adding a certain number of cells between sets of data based on a comparison



Frisbee68
07-28-2017, 11:20 AM
Hello everyone, first post in here so I hope I do everything correctly. I am trying to line up 2 sets of data both of which have multiple columns. The second set of data has more values than the first, but I would like for both sets of to have the same number of total rows. To do this, I am trying to add blank cells beneath the data of the first set whenever the numbers don't line up. See below for an example:



1
411111
411111
1


2
422222
411111
1


3
433333
422222
2




422222
2




422222
2




433333
3




I would like the above to look like this:



76
411111
411111
76




411111
23


12
422222
422222
12




422222
18




422222
50


9
433333
433333
9




I have been using a piece of code I have seen circulated along with an IF statement in E column (to return 0 if the numbers don't match) to help with this but it does not seem to do the trick as it lowers the entire row and messes up the alignment of the 2 sets of data. Here is what I am using:


Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "E"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "0" Then
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub


I'm not an expert with VBA so I'm not quite sure what I can change in order to achieve what I am trying to do. I have two options that I can think of, which is to either have a code that cycles through adding a whole row and then restarts on the next line (so that the whole file isn't spaced out all at once, misaligning the data), or a code that can add blank cells to multiple specific columns. My first column of data is 753 cells and the second cell is 853 cells if that makes any difference. Any help is greatly appreciated.

Thanks!

offthelip
07-29-2017, 01:13 AM
try this:


Sub movedata()
inarr = Range(Cells(1, 1), Cells(853, 2))
matchr = Range(Cells(1, 3), Cells(853, 4))
Range(Cells(1, 1), Cells(853, 2)) = ""
outarr = Range(Cells(1, 1), Cells(853, 2))
For i = 1 To 753
For j = 1 To 853
If inarr(i, 2) = matchr(j, 1) Then
outarr(j, 1) = inarr(i, 1)
outarr(j, 2) = inarr(i, 2)
Exit For
End If
Next j
Next i


Range(Cells(1, 1), Cells(853, 2)) = outarr



End Sub

Frisbee68
07-31-2017, 07:46 AM
Hi there, thanks for your quick reply. This code is really helpful, but I have noticed one small bug that I cannot seem to fix by myself. It seems as though if the first 2 values in the second column are duplicates, the first gets deleted. Something like this:

Before macro:


14
411111
400000
23


11
411111
411111
14


73
422222
411111
11


8
433333
422222
73




422222
56




433333
8



After macro:




40000
23


11
411111
411111
14




411111
11


73
422222
422222
73




422222
56


8
433333
433333
8



So if the column on the left side starts with a duplicate, the first row is deleted instead of spaced down. If the left side doesn't start with a duplicate, everything runs properly. I can't seem to figure out what is deleting the value on the left side.

*UPDATE* Upon further investigation, the code seems to be deleting any duplicate values in the left range ((1,1) to (853,2)) instead of simply added spaces. Is there any way I can get it to add a space rather than delete the values there?

offthelip
07-31-2017, 08:42 AM
try changing ;


If inarr(i, 2) = matchr(j, 1) Then

to


If inarr(i, 2) = matchr(j, 1) and outarr(j,1)="" Then

Note, Not tested but hopefully will fix it.