macro to copy and paste a cell value Hello, I have a file that we get as a downl

Question

macro to copy and paste a cell value

Hello, I have a file that we get as a download from another program. I am using it for reporting and it is kind of "dirty" so I am trying to use a macro to clean it up and make it usable for reporting. What I want to do is insert a column in front of A and then find the cell which is now in column B the starts with "Business Unit" and paste that beside, Column A, any cell below it that has a value until the next "Business Unit" is found. There are over 30 Business Units that this would need to be done for.

Column B is originally column A will shift over with the column insert.

So it looks like this:  

Column A              Column B

                             Business Unit 1   

Business Unit 1    Insurance

Business Unit 1    MDCR

Business Unit 1    MDCD

Business Unit 1    VA

                            Business Unit 2   

Business Unit 2    Insurance

Business Unit 2    MDCR

Business Unit 2    MDCD

Business Unit 2    VA

The macro that I am trying to get to work.

Sub Allscript_AR_Fix()

Dim ws As Worksheet
Set ws = Sheet2

ws.Columns(1).Insert

c = 2
r = 1

ws.Select
ws.Cells(50000, c).Select
Selection.End(xlUp).Select
last_row = ActiveCell.Row

    Do While r <= last_row
        If UCase(Left(ws.Cells(r, c), 13)) = "BUSINESS UNIT" Then
            Header_Cell = ws.Cells(r, 2)
            ws.Cells(r, c).Copy
            counter = 0
        End If
       
        counter = counter + ws.Cells(r, c)
       
        If ws.Cells(r, c) > "" Then
            ws.Cells(r, 1).Paste
            cnt = cnt + 1
        End If
   
    Loop

ws.Cells(1).Select
    
End Sub

Thank!!!

Explanation / Answer

I now agree with the comment in your first post that the file is 'Dirty' with no regular structure in the Column A as you receive it. Try this one which is 99% IMO. It gets it wrong in 1 place and that's where we have the inconsistent structure in Col A where there is no blank row.

Sub GrabAll()
Dim LastRow As Long, ws As Worksheet
Dim c As Range, MyRange As Range
Dim CopyRange As Range, Area As Range
Set ws = Sheets("Sheet1")
ws.Columns(1).Insert
LastRow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row
Set MyRange = ws.Range("B1:B" & LastRow)
For Each c In MyRange
     If UCase(Left(c.Value, 13)) = "BUSINESS UNIT" Then
        c.Offset(, -1) = c.Value
        If CopyRange Is Nothing Then
            Set CopyRange = c.Offset(, -1)
        Else
            Set CopyRange = Union(CopyRange, c.Offset(, -1))
        End If
    End If
Next
For Each Area In ws.Range("A5:A" & LastRow). _
                   SpecialCells(xlCellTypeBlanks).Areas
    For x = 2 To Area.Cells.Count - 1
        Area.Cells(x) = Area(1).Offset(-1).Value
        If UCase(WorksheetFunction.Trim(Area.Cells(x).Offset(, 2))) = "TOTAL FOR" Then
        Exit For
        End If
     Next

Next
If Not CopyRange Is Nothing Then
CopyRange.ClearContents
End If
ws.Columns(1).AutoFit
End Sub

Related Questions

Navigate

• Browse (All)
• Browse M
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.