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:



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:



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:

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?