CODEWITHSUNDEEP
excelvba
smrmodel78
smrmodel78

Reputation: 47

VBA macro to Format Worksheet Data to create table

I have the following unformatted file that I need to somehow format in vba before I create a table. The macro needs to:

  1. create a header row with the dates until last used column and move to row 1 for column headers
  2. move the group names highlighted in blue in column B to column A for the budget & actual
  3. delete blank rows (have this code already)
  4. turn into table (have this code already)

Is there an easy way to do this? Every month this file gets copied somewhere and I have to manually adjust all the formatting and there are hundreds of rows like this.

enter image description here

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Prompts user for location of the Member Count File, then
'               copies it in the Active Workbook & Formats File
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CopyMemberData()
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
Dim x As Long
    
Set wb1 = ThisWorkbook 'CYTD File

Application.ScreenUpdating = False

'**************Get File Location for Member Count Data
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Open Membership Analysis File")

If my_Filename = False Then
    Exit Sub
End If

Set wb2 = Workbooks.Open(my_Filename) 'Membership Analysis File

'**************Copy Membership Data Details
wb2.Sheets("Membership data_Charts by LOB").Cells.Copy _
wb1.Sheets("MemberCount").Range("A1")
wb2.Close

'**************Format Sheet
With ActiveSheet

    'Create Header Row
 
    'Deletes Blank Rows
'    For x = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
'        If WorksheetFunction.CountA(.Rows(x)) = 0 Then
'            ActiveSheet.Rows(x).Delete
'        End If
'    Next
 
End With

Application.ScreenUpdating = True

MsgBox "Membership Analysis Complete. Hit F9 to refresh Data", vbOKOnly
    
End Sub

Upvotes: 0

Views: 390

Answers (1)

Tim Williams
Tim Williams

Reputation: 166366

This would take care of the headers in colB

Dim c As Range, ws As Worksheet

Set ws = ActiveSheet

For Each c In ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp)).Cells
    If c.Font.Bold Then
        c.Offset(1, -1).Resize(2, 1).Value = c.Value 'copy over
        c.ClearContents                              'clear
    End If
Next c

Upvotes: 1

Related Questions