• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 46
  • Last Modified:

Marco to move data and remove balnk rows

I have an excel spreadsheet which is the result of exporting data from a crystal report
The crystal report has data from a sub report and apparently the following exists
"The export to Excel is designed to export the subreport to the "next" row.  There is nothing you can do about that."

So is it possible to have a macro that puts the data under the correct headings and removes the blank rows
Have attached the excel file
Example the figures in row 3 should be in row 2 under the headings:-  Reg Hrs Qty      Reg Hrs Cost      O/T Hrs Qty      O/T Factor      OT Hrs Cost      Total Hrs Cost

Noting that some records do not contain data to move (example row 65)

Gordon
Test-Chargeable.xlsx
0
Gordon Hughes
Asked:
Gordon Hughes
  • 6
  • 3
  • 3
2 Solutions
 
Rgonzo1971Commented:
HI,

pls try
Sub macro()
Application.ScreenUpdating = False
Set Rng = Range(Range("A2"), Range("A" & Rows.Count))
For Each c In Rng.SpecialCells(xlCellTypeConstants, xlTextValues)
    c.Offset(1).Resize(1, 6).Copy c.Offset(, 12)
Next
Rng.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Delete
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Open in new window

Regards
0
 
NorieVBA ExpertCommented:
Try this, it puts the result on a new sheet.
Sub TransformChargeable()
Dim arrIn As Variant
Dim arrOut()
Dim I As Long
Dim J As Long
Dim cnt As Long
    
    With Sheets("Sheet1")
     arrIn = .Range("A2", .Range("A" & Rows.Count).End(xlUp).Offset(, 11)).Value
    End With
    
    I = 1
    Do
        cnt = cnt + 1
        ReDim Preserve arrOut(1 To 18, 1 To cnt)
        
        For J = 1 To 12
            arrOut(J, cnt) = arrIn(I, J)
        Next J
        
        If arrIn(I + 1, 1) <> "" Then
            For J = 1 To 6
                arrOut(J + 12, cnt) = arrIn(I + 1, J)
            Next J
            I = I + 3
        Else
            I = I + 2
        End If
        
    Loop Until I > UBound(arrIn, 1)
    
    Sheets.Add
    
    ActiveSheet.Rows(1).Value = Sheets("Sheet1").Rows(1).Value
    
    ActiveSheet.Range("A2").Resize(UBound(arrOut, 2), UBound(arrOut, 1)).Value = Application.Transpose(arrOut)

End Sub

Open in new window

0
 
Gordon HughesDirectorAuthor Commented:
Hi Rgonzo1971

The macro seems to work well
How do I save it so that the macro can be seen and used where required on any excel spreadsheet
Gordon
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Gordon HughesDirectorAuthor Commented:
In principle I like the idea of saving the data in the format required in a new spreadsheet. the solution from Norie converts the date format from English to American format
But still don't know how to save the macro so that is accessible from any excel spreadsheet
Gordon
0
 
Rgonzo1971Commented:
by creating a PERSONAL.xlsb file you can put the macros to be used in all the worksheets

the PERSONAL.xlsb is opened whenever excel is opening

so create a dummy macro like in the link then put the my code in the created module
0
 
NorieVBA ExpertCommented:
Gordon

I didn't notice that about the date/times, I'll try and fix it and post back.
0
 
Gordon HughesDirectorAuthor Commented:
Ok am getting there can we fix the date format on the second solution?
Gordon
0
 
Gordon HughesDirectorAuthor Commented:
Thanks Norie
0
 
NorieVBA ExpertCommented:
Gordon

This should sort out the date problem and tidy things up a bit too.
Sub TransformChargeable()
Dim arrIn As Variant
Dim arrOut()
Dim I As Long
Dim J As Long
Dim cnt As Long
    
    With Sheets("Sheet1")
        arrIn = .Range("A2", .Range("A" & Rows.Count).End(xlUp).Offset(, 11)).Value
    End With
    
    I = 1
    Do
        cnt = cnt + 1
        ReDim Preserve arrOut(1 To 18, 1 To cnt)
        
        For J = 1 To 12
        If J = 6 Or J = 7 Then
            arrOut(J, cnt) = DateValue(arrIn(I, J)) + TimeValue(arrIn(I, J))
        Else
            arrOut(J, cnt) = arrIn(I, J)
        End If
        Next J
        
        If arrIn(I + 1, 1) <> "" Then
            For J = 1 To 6
                arrOut(J + 12, cnt) = arrIn(I + 1, J)
            Next J
            I = I + 3
        Else
            I = I + 2
        End If
        
    Loop Until I > UBound(arrIn, 1)
    
    Sheets.Add
    
    With ActiveSheet
    
        With .Range("A2").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
            .Value = arrOut
            .Copy
        End With
    
        .Range("A20").PasteSpecial xlPasteValues, Transpose:=True
        .Range("2:19").Delete
        .Rows(1).Value = Sheets("Sheet1").Rows(1).Value
        .Range("F:G").NumberFormat = "dd/mm/yyyy hh:mm"
        .UsedRange.EntireColumn.AutoFit
        
    End With
    
End Sub

Open in new window

0
 
Gordon HughesDirectorAuthor Commented:
Hi Norie
All looks good now
Gordon
0
 
Gordon HughesDirectorAuthor Commented:
Thanks all
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Python 3 Fundamentals

This course will teach participants about installing and configuring Python, syntax, importing, statements, types, strings, booleans, files, lists, tuples, comprehensions, functions, and classes.

  • 6
  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now