VBA copy cell data based on value in columns

[CJW_14]

Hi All,

Finally decided to sign up on this forum, so much great info here!

I'm fairly new to writing macro's but can usually work my way through what I need to do with some searching and basic editing of the code.

However I have something more complex I'm struggling with and not sure where to start or what's possible.

I have the following example set of data below:

https://s33.postimg.cc/rg6qkvv1r/2018-06-28_142909.jpg

To try and explain simply, I want to write a macro which finds a "Y" in columns C-E and copies the data from columns F-H, I-K and L-M on to separate rows. The output (or something similar) of what I'm trying to achieve is below:

https://s33.postimg.cc/mlm8ei3wf/2018-06-28_144423output.jpg

Any help or direction would be greatly appreciated :)

[Kenneth Hobs]

Welcome to the forum!

Change Output2 to your output sheet name. Change border formatting to suit.

Test code in a backup copy. Put this code into a Module and Run.

Sub Main()
Dim r As Range, c As Range, o As Worksheet
Dim s As Worksheet, w As Long, cw As Long, i As Integer

Set s = Worksheets("Source")
Set r = s.Range("C3:E" & s.Cells(Rows.Count, "A").End(xlUp).Row)
Set o = Worksheets("Output2") 'Change sheetname to suit

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

With o
For Each c In r
If c <> "Y" Then GoTo NextC
For i = 6 To 12 Step 3
w = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
cw = c.Row
s.Cells(cw, "A").Copy .Cells(w, "A") 'Division
s.Cells(cw, "B").Copy .Cells(w, "B") 'Divison Name
s.Cells(2, c.Column).Copy .Cells(w, "C") 'Area
s.Cells(cw, i).Copy .Cells(w, "D") 'Payment Number
s.Cells(cw, i + 1).Copy .Cells(w, "E") 'Amount
s.Cells(cw, i + 2).Copy .Cells(w, "F") 'Comment
Next i
NextC:
Next c
End With

'Set border formats
With o.Range("A2:F" & o.Cells(o.Rows.Count, "A").End(xlUp).Row)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
End Sub

[CJW_14]

Thanks so much for this, works perfectly!

[CJW_14]

Is it possible to copy the cell value rather than the actual cell? Having alot of formatting issue's :)

[Kenneth Hobs]

Rather than Copy method, you can use Value, Value2, and NumberFormat or such. e.g.

's.Cells(cw, "A").Copy .Cells(w, "A")
'Division.Cells(w, "A").Value = s.Cells(cw, "A").Value 'Division
.Cells(w, "A").NumberFormat = s.Cells(cw, "A").NumberFormat

[CJW_14]

Thanks for the update, appreciate it.

[CJW_14]

Hi all,

I made a few changes to the code mainly because the number of columns have increased in my source data.


Sub CONVERTData()

Dim r As Range, c As Range, o As Worksheet
Dim s As Worksheet, w As Long, cw As Long, i As Integer

Set s = Worksheets("Current_State")
Set r = s.Range("C2:R" & s.Cells(Cells.ROWS.Count, "A").End(xlUp).Row)
Set o = Worksheets("Output") 'Change sheetname to suit

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

With o
For Each c In r
If c <> "Y" Then GoTo NextC
For i = 19 To 97 Step 7
w = .Cells(.ROWS.Count, "A").End(xlUp).Row + 1
cw = c.Row
s.Cells(cw, "A").Copy .Cells(w, "A") 'Division
s.Cells(cw, "B").Copy .Cells(w, "B") 'Division Name
s.Cells(1, c.Column).Copy .Cells(w, "C") 'Area
s.Cells(cw, i).Copy .Cells(w, "D") 'Payment number
s.Cells(cw, i + 1).Copy .Cells(w, "E") 'Amount
s.Cells(cw, i + 2).Copy .Cells(w, "F") 'Payee
s.Cells(cw, i + 3).Copy .Cells(w, "G") 'ID
s.Cells(cw, i + 4).Copy .Cells(w, "H") 'Group
s.Cells(cw, i + 5).Copy .Cells(w, "I") 'Location
s.Cells(cw, i + 6).Copy .Cells(w, "J") 'Comments

Next i
NextC:
Next c

End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
End Sub

A couple of problems I'm finding are:


The code runs perfectly on a small data set but freezes when trying to convert 100+ rows
I've also found i'm creating an excess number of rows with no data when the payment number sections are blank. I'm thinking is there a way to exclude converting the payment number based on the "amount" column being blank? Example below:


https://s33.postimg.cc/p6yxkcigv/screen_dump_example.png

Any help would be greatly appreciated :)

[CJW_14]

I figured out what was making the code stop and it appears to be data someone pasted from another workbook and the cells were linked but broken. Other than that I just need to patient with letting it run :)

Just need to figure out how to remove the excess rows now..

[Kenneth Hobs]

If you can attach a short example with cases of empty and how output would look, I can look at it. One can either fix after the run or skip during the run. Skipping is likely the more efficient method.

As for speed, the best would be to use an array method. I can look at that too. The only extra formatting would be for the custom currency column.

[CJW_14]

Thanks a lot really appreciate your help :)

I've attached an updated example file. In the output sheet I coloured the rows in red which Id like to exclude.

At a minimum for a row to be included in the output, either the "amount" or "comment" column would have be populated (I've included this in the example).

Any questions let me know, thanks again..

[Kenneth Hobs]

I did not add back the output header row nor formats. You can easily add them manually in a template sheet or ask for help if needed.

This should get you close.

Sub CONVERTDataA()
Dim r As Range, c As Range, o As Worksheet
Dim s As Worksheet, cw As Long, i As Integer
Dim f&, e&, a, j As Integer

Set s = Worksheets("Current_State")
f = 19 'Payment Number Column (first)
e = s.Cells(1, Columns.Count).End(xlToLeft).Column - 6 'Payment Number Column (end)
Set r = s.Range("C2", s.Cells(s.Cells(s.Cells.Rows.Count, "A").End(xlUp).Row, f - 1))
Set o = Worksheets("Output2") 'Change sheetname to suit

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

ReDim a(1 To r.Rows.Count * (e - f) / 7, 1 To 10)
j = 1
With s
For Each c In r
If c <> "Y" Then GoTo NextC
For i = f To e Step 7 '19 To 96 Step 7
cw = c.Row
If .Cells(cw, i + 1).Value = "" Then GoTo NextI 'Amount
a(j, 1) = .Cells(cw, "A").Value 'Division
a(j, 2) = .Cells(cw, "B").Value 'Division Name
a(j, 3) = .Cells(1, c.Column).Value 'Area
a(j, 4) = .Cells(cw, i).Value 'Payment Number
a(j, 5) = .Cells(cw, i + 1).Value 'Amount
a(j, 6) = .Cells(cw, i + 2).Value 'Payee
a(j, 7) = .Cells(cw, i + 3).Value 'ID
a(j, 8) = .Cells(cw, i + 4).Value 'Group
a(j, 9) = .Cells(cw, i + 5).Value 'Location
a(j, 10) = .Cells(cw, i + 6).Value 'Comments
j = j + 1 'increment array a index counter
NextI:
Next i
NextC:
Next c
End With

o.Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
End Sub

[CJW_14]

You are a legend mate, thanks alot! works great and the run time is significantly less.

[CJW_14]

Hi Kenneth

I have been running the code heaps and it has been working well.

In a small number of cases I'm receiving a run-time error 9 – subscript out of range

I narrowed down the problem to the additional red section of code I added, as once removed it executes without the error.


If .Cells(cw, i + 1).Value = "" And .Cells(cw, i + 6).Value = "" Then GoTo NextI

Would you have any advice? I have tried a few different things and I haven’t been able to fix it.

[Kenneth Hobs]

Try Dim I as long but it should not be needed.

[CJW_14]

I thought that might have been it aswell but made no difference.

[CJW_14]

Whats unusual is I emailed home one of the files that was getting the subscript out of range error, and works fine on my home PC. It wouldn't have anything to do with the .cells reference?