Macro Code Help

Z

zach9208

Board Regular
Joined
Dec 15, 2015
Messages
117
I am trying to set my macro file to remove formats from columns that have spaces in them (See CRMCleanup) I tried just adding a Call CRMCleanup piece of code to my UpdateHeadersCRM code but I keep getting an error saying the sheet is still protected. I need to cleanup or merge my code for the CRMCleanup code into the UpdateHeadersCRM code. Any ideas?


Code: 
Sub DoWork(wb As Workbook)    UpdateHeadersAspirational wb.Sheets("Apsirational") 'The template files have the tab "Aspirational" mispelled as "Apsirational"
    UpdateHeadersCRM wb.Sheets("CRM")


End Sub

Code: 
Sub ProcessFiles()Dim wb As Workbook
Dim Filename As String, Pathname As String


    Pathname = "C:\Users\c755748\Desktop\TEST2\" 'This is the file path the templates need saved to in order for the macro to clean the file formats up in prep for the database
    Filename = Dir(Pathname & "*.xlsx")


    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop


End Sub


Code: 
Sub UpdateHeadersCRM(ws As Worksheet)

    With ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook
        .Range("A1:W3").Delete Shift:=xlUp 'Need to adjust range if a new column is added or removed
        
        'Re-names row 1 with the column names for the database. Update these fields if a new column is added or removed.
        .Range("A1").Value = "WGTD_SLS_CAL_AMT"
        .Range("B1").Value = "EST_RVNU_AMT"
        .Range("C1").Value = "EST_BPS_AMT"
        .Range("D1").Value = "WT_PRC"
        .Range("E1").Value = "AVG_BPS_AMT"
        .Range("F1").Value = "EST_FDNG_QTR_NM"
        .Range("G1").Value = "OPTY_NMBR"
        .Range("H1").Value = "CO_NM"
        .Range("I1").Value = "CNSLT_NM"
        .Range("J1").Value = "PRMY_PRDCT_NM"
        .Range("K1").Value = "BTQ_PRMY_PRDCT_TYP_NM"
        .Range("L1").Value = "INV_VHCL_2_NM"
        .Range("M1").Value = "PLNE_STP_NM"
        .Range("N1").Value = "RNKG_TYP_NM"
        .Range("O1").Value = "CRNCY_NM"
        .Range("P1").Value = "EST_MNDT_AMT"
        .Range("Q1").Value = "EST_MNDT_USD_AMT"
        .Range("R1").Value = "EST_DCSN_DT"
        .Range("S1").Value = "TM_MBR_NM"
        .Range("T1").Value = "RGN_4_NM"
        .Range("U1").Value = "OPTY_TYP_NM"
        .Range("V1").Value = "MOD_DT"
        .Range("W1").Value = "STAT_UPDT_TXT"


      Call CRMCleanup
    End With
    
End Sub

Code: 
Sub CRMCleanup() 'Need to adjust range if a new column is added or removed. This is needed in order to cleanup excess blank columns    
    Sheets("CRM").Unprotect
    Columns("X:AWY").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Clear
    
End Sub
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
Try this
Code: 
Sub UpdateHeadersCRM(ws As Worksheet)

    With ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook

        .Range("A1:W3").Delete Shift:=xlUp 'Need to adjust range if a new column is added or removed
        
        'Re-names row 1 with the column names for the database. Update these fields if a new column is added or removed.
        .Range("A1").Value = "WGTD_SLS_CAL_AMT"
        .Range("B1").Value = "EST_RVNU_AMT"
        .Range("C1").Value = "EST_BPS_AMT"
        .Range("D1").Value = "WT_PRC"
        .Range("E1").Value = "AVG_BPS_AMT"
        .Range("F1").Value = "EST_FDNG_QTR_NM"
        .Range("G1").Value = "OPTY_NMBR"
        .Range("H1").Value = "CO_NM"
        .Range("I1").Value = "CNSLT_NM"
        .Range("J1").Value = "PRMY_PRDCT_NM"
        .Range("K1").Value = "BTQ_PRMY_PRDCT_TYP_NM"
        .Range("L1").Value = "INV_VHCL_2_NM"
        .Range("M1").Value = "PLNE_STP_NM"
        .Range("N1").Value = "RNKG_TYP_NM"
        .Range("O1").Value = "CRNCY_NM"
        .Range("P1").Value = "EST_MNDT_AMT"
        .Range("Q1").Value = "EST_MNDT_USD_AMT"
        .Range("R1").Value = "EST_DCSN_DT"
        .Range("S1").Value = "TM_MBR_NM"
        .Range("T1").Value = "RGN_4_NM"
        .Range("U1").Value = "OPTY_TYP_NM"
        .Range("V1").Value = "MOD_DT"
        .Range("W1").Value = "STAT_UPDT_TXT"

       [COLOR=#0000ff] .Columns("X:XFD").Clear[/COLOR]

    End With
    
End Sub
The line in blue replaces your CRMCleanup sub
 
Upvote 0
This code change worked but I ran into a new snag that I was not even thinking about. I need the macro to detect the last row that has data and clear all of the rows below this last row. For example, row 206 is the last row with data, I need the macro to select from row 206 all the way to the end of the sheet and clear any cell formatting or spaces. Note: each of the files that I run my macro through has a different row number where data is last populated in. Column H is a good indicator or where the data ends in the workbook.

I need this formatting clean in order for my Access macro to stop pulling in blank row records when importing all of my individual data files. In case you are wondering what the access macro looks like it is this. I am open to adding code to either the access macro (PullData) or the excel macro (UpdateHeadersCRM). Any ideas for this?

Code: 
Public Sub PullData()
Dim strPathFile As String, strFile As String, strPath As String
 Dim blnHasFieldNames As Boolean
 Dim intWorksheets As Integer
' Replace 3 with the number of worksheets to be imported
 ' from each EXCEL file
 Dim strWorksheets(1 To 2) As String
' Replace 3 with the number of worksheets to be imported
 ' from each EXCEL file (this code assumes that each worksheet
 ' with the same name is being imported into a separate table
 ' for that specific worksheet name)
 Dim strTables(1 To 2) As String
' Replace generic worksheet names with the real worksheet names;
 ' add / delete code lines so that there is one code line for
 ' each worksheet that is to be imported from each workbook file
 strWorksheets(1) = "Apsirational"
 strWorksheets(2) = "CRM"
 
' Replace generic table names with the real table names;
 ' add / delete code lines so that there is one code line for
 ' each worksheet that is to be imported from each workbook file
 strTables(1) = "1-tblForecastStaging"
 strTables(2) = "1-tblForecastStaging"

' Change this next line to True if the first row in EXCEL worksheet
 ' has field names
 blnHasFieldNames = True
' Replace C:\Documents\ with the real path to the folder that
 ' contains the EXCEL files
 strPath = "C:\Users\c_____\Desktop\TEST2\"
' Replace 3 with the number of worksheets to be imported
 ' from each EXCEL file
 For intWorksheets = 1 To 2
       strFile = Dir(strPath & "*.xls")
       Do While Len(strFile) > 0
             strPathFile = strPath & strFile
             DoCmd.TransferSpreadsheet acImport, _
                   acSpreadsheetTypeExcel9, strTables(intWorksheets), _
                   strPathFile, blnHasFieldNames, _
                   strWorksheets(intWorksheets) & "$"
             strFile = Dir()
       Loop
 Next intWorksheets
End Sub



Fluff said:
Try this
Code: 
Sub UpdateHeadersCRM(ws As Worksheet)

     With ws
         .Application.ScreenUpdating = False
         
         .Unprotect 'Unprotects the workbook

         .Range("A1:W3").Delete Shift:=xlUp 'Need to adjust range if a new column is added or removed
         
         'Re-names row 1 with the column names for the database. Update these fields if a new column is added or removed.
         .Range("A1").Value = "WGTD_SLS_CAL_AMT"
         .Range("B1").Value = "EST_RVNU_AMT"
         .Range("C1").Value = "EST_BPS_AMT"
         .Range("D1").Value = "WT_PRC"
         .Range("E1").Value = "AVG_BPS_AMT"
         .Range("F1").Value = "EST_FDNG_QTR_NM"
         .Range("G1").Value = "OPTY_NMBR"
         .Range("H1").Value = "CO_NM"
         .Range("I1").Value = "CNSLT_NM"
         .Range("J1").Value = "PRMY_PRDCT_NM"
         .Range("K1").Value = "BTQ_PRMY_PRDCT_TYP_NM"
         .Range("L1").Value = "INV_VHCL_2_NM"
         .Range("M1").Value = "PLNE_STP_NM"
         .Range("N1").Value = "RNKG_TYP_NM"
         .Range("O1").Value = "CRNCY_NM"
         .Range("P1").Value = "EST_MNDT_AMT"
         .Range("Q1").Value = "EST_MNDT_USD_AMT"
         .Range("R1").Value = "EST_DCSN_DT"
         .Range("S1").Value = "TM_MBR_NM"
         .Range("T1").Value = "RGN_4_NM"
         .Range("U1").Value = "OPTY_TYP_NM"
         .Range("V1").Value = "MOD_DT"
         .Range("W1").Value = "STAT_UPDT_TXT"

       [COLOR=#0000ff] .Columns("X:XFD").Clear[/COLOR]

     End With
     
 End Sub
The line in blue replaces your CRMCleanup sub
Click to expand...
 
Last edited:
Upvote 0
2 options
1) add the rows in blue to your existing macro.
2) add your field names to the part in red & use this as-is. The if field names change, simply modify the part in red & the rest will be taken care of
Code: 
Sub UpdateHeadersCRM(Ws As Worksheet)

    Dim Hdrs() As Variant
    [COLOR=#0000ff]Dim NxtRw As Long[/COLOR]
    Dim Cnt As Long
    
    Hdrs = Array([COLOR=#ff0000]"WGTD_SLS_CAL_AMT", "EST_RVNU_AMT", "EST_BPS_AMT", "WT_PRC" _
            , "AVG_BPS_AMT"[/COLOR])
    
    With Ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook

        .Range("A1").Resize(3, CInt(UBound(Hdrs)) + 1).Delete Shift:=xlUp
        
        For Cnt = 0 To UBound(Hdrs)
            Cells(1, Cnt + 1) = Hdrs(Cnt)
         Next Cnt

        .Columns("X:XFD").Clear
        [COLOR=#0000ff]NxtRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1).Row
        .Range("A" & NxtRw, "A" & Rows.Count).EntireRow.Delete
[/COLOR]
    End With
    
End Sub
 
Last edited:
Upvote 0
I tried adding the code in blue to the macro to my excel macro and my database macro picked up a bunch of blank rows. If I were to use the code highlighted in red, do I include the following too. I guess I do not really understand what this piece is doing.

I need the rows to below my last data line to be completely empty (no spaces, no formatting, ect.). I used the clear button manually on the workbooks and the access macro did not load the extra lines.


Code: 
.Range("A1").Resize(3, CInt(UBound(Hdrs)) + 1).Delete Shift:=xlUp        
        For Cnt = 0 To UBound(Hdrs)
            Cells(1, Cnt + 1) = Hdrs(Cnt)
         Next Cnt


Fluff said:
2 options
1) add the rows in blue to your existing macro.
2) add your field names to the part in red & use this as-is. The if field names change, simply modify the part in red & the rest will be taken care of
Code: 
Sub UpdateHeadersCRM(Ws As Worksheet)

    Dim Hdrs() As Variant
    [COLOR=#0000ff]Dim NxtRw As Long[/COLOR]
    Dim Cnt As Long
    
    Hdrs = Array([COLOR=#ff0000]"WGTD_SLS_CAL_AMT", "EST_RVNU_AMT", "EST_BPS_AMT", "WT_PRC" _
            , "AVG_BPS_AMT"[/COLOR])
    
    With Ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook

        .Range("A1").Resize(3, CInt(UBound(Hdrs)) + 1).Delete Shift:=xlUp
        
        For Cnt = 0 To UBound(Hdrs)
            Cells(1, Cnt + 1) = Hdrs(Cnt)
         Next Cnt

        .Columns("X:XFD").Clear
        [COLOR=#0000ff]NxtRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1).Row
        .Range("A" & NxtRw, "A" & Rows.Count).EntireRow.Delete
[/COLOR]
    End With
    
End Sub
Click to expand...
 
Upvote 0
With the code you posted
Code: 
Sub UpdateHeadersCRM(ws As Worksheet)

    Dim NxtRw As Long
    
    With ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook

        .Range("A1:W3").Delete Shift:=xlUp 'Need to adjust range if a new column is added or removed
        
        'Re-names row 1 with the column names for the database. Update these fields if a new column is added or removed.
        .Range("A1").Value = "WGTD_SLS_CAL_AMT"
        .Range("B1").Value = "EST_RVNU_AMT"
        .Range("C1").Value = "EST_BPS_AMT"
        .Range("D1").Value = "WT_PRC"
        .Range("E1").Value = "AVG_BPS_AMT"
        .Range("F1").Value = "EST_FDNG_QTR_NM"
        .Range("G1").Value = "OPTY_NMBR"
        .Range("H1").Value = "CO_NM"
        .Range("I1").Value = "CNSLT_NM"
        .Range("J1").Value = "PRMY_PRDCT_NM"
        .Range("K1").Value = "BTQ_PRMY_PRDCT_TYP_NM"
        .Range("L1").Value = "INV_VHCL_2_NM"
        .Range("M1").Value = "PLNE_STP_NM"
        .Range("N1").Value = "RNKG_TYP_NM"
        .Range("O1").Value = "CRNCY_NM"
        .Range("P1").Value = "EST_MNDT_AMT"
        .Range("Q1").Value = "EST_MNDT_USD_AMT"
        .Range("R1").Value = "EST_DCSN_DT"
        .Range("S1").Value = "TM_MBR_NM"
        .Range("T1").Value = "RGN_4_NM"
        .Range("U1").Value = "OPTY_TYP_NM"
        .Range("V1").Value = "MOD_DT"
        .Range("W1").Value = "STAT_UPDT_TXT"

        .Columns("X:XFD").Clear
        NxtRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1).Row
        .Range("A" & NxtRw, "A" & Rows.Count).Clear

    End With
    
End Sub
 
Upvote 0
Alternatively
Code: 
Sub UpdateHeadersCRM(Ws As Worksheets)

    Dim Hdrs() As Variant
    Dim NxtRw As Long
    Dim Cnt As Long
    
    Hdrs = Array([COLOR=#ff0000]"WGTD_SLS_CAL_AMT", "EST_RVNU_AMT", "EST_BPS_AMT", "WT_PRC" _
            , "AVG_BPS_AMT", "EST_FDNG_QTR_NM", "OPTY_NMBR", "CO_NM", "CNSLT_NM" _
            , "PRMY_PRDCT_NM", "BTQ_PRMY_PRDCT_TYP_NM", "INV_VHCL_2_NM", "PLNE_STP_NM" _
            , "RNKG_TYP_NM", "CRNCY_NM", "EST_MNDT_AMT", "EST_MNDT_USD_AMT" _
            , "EST_DCSN_DT", "TM_MBR_NM", "RGN_4_NM", "OPTY_TYP_NM", "MOD_DT", "STAT_UPDT_TXT"[/COLOR])
    
    With Ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook

        .Range("A1").Resize(3, CInt(UBound(Hdrs)) + 1).Delete Shift:=xlUp
        
        For Cnt = 0 To UBound(Hdrs)
            .Cells(1, Cnt + 1) = Hdrs(Cnt)
         Next Cnt

        .Columns(UBound(Hdrs) + 2).Resize(, 16383 - UBound(Hdrs)).Clear
        NxtRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1).Row
        .Range("A" & NxtRw, "A" & Rows.Count).Clear

    End With
    
End Sub
The part in red is your Field values. Simply modify them as & when needed & the rest of the macro will take care of itself.
If you add another value then the macro will put that in Col X & clear col Y to the end
 
Upvote 0
I appreciate your quick response Fluff. You have been a huge help. I will try these macros when I return to work first thing in the morning.
Fluff said:
Alternatively
Code: 
Sub UpdateHeadersCRM(Ws As Worksheets)

    Dim Hdrs() As Variant
    Dim NxtRw As Long
    Dim Cnt As Long
    
    Hdrs = Array([COLOR=#ff0000]"WGTD_SLS_CAL_AMT", "EST_RVNU_AMT", "EST_BPS_AMT", "WT_PRC" _
            , "AVG_BPS_AMT", "EST_FDNG_QTR_NM", "OPTY_NMBR", "CO_NM", "CNSLT_NM" _
            , "PRMY_PRDCT_NM", "BTQ_PRMY_PRDCT_TYP_NM", "INV_VHCL_2_NM", "PLNE_STP_NM" _
            , "RNKG_TYP_NM", "CRNCY_NM", "EST_MNDT_AMT", "EST_MNDT_USD_AMT" _
            , "EST_DCSN_DT", "TM_MBR_NM", "RGN_4_NM", "OPTY_TYP_NM", "MOD_DT", "STAT_UPDT_TXT"[/COLOR])
    
    With Ws
        .Application.ScreenUpdating = False
        
        .Unprotect 'Unprotects the workbook

        .Range("A1").Resize(3, CInt(UBound(Hdrs)) + 1).Delete Shift:=xlUp
        
        For Cnt = 0 To UBound(Hdrs)
            .Cells(1, Cnt + 1) = Hdrs(Cnt)
         Next Cnt

        .Columns(UBound(Hdrs) + 2).Resize(, 16383 - UBound(Hdrs)).Clear
        NxtRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1).Row
        .Range("A" & NxtRw, "A" & Rows.Count).Clear

    End With
    
End Sub
The part in red is your Field values. Simply modify them as & when needed & the rest of the macro will take care of itself.
If you add another value then the macro will put that in Col X & clear col Y to the end
Click to expand...
 
Upvote 0
I tried these macros this morning. The macro with the array did not work for me it gave me an error. I tried the other macro and it still does not seem to be clearing those rows. I determined this by highlighting some rows after the data ends and after running the macro it still shows the formatting. QUOTE=zach9208;4926327]I appreciate your quick response Fluff. You have been a huge help. I will try these macros when I return to work first thing in the morning.[/QUOTE]
 
Upvote 0
What error did you get & what row is highlighted if you click debug?
Also what column can be used to find the last row of data?
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question
How to shorten vba code without any problems
Replies
1
Views
45
kamranyd
K
A
  • Solved
VBA Help!
Replies
2
Views
115
AusNewb
A
O
  • Question
Multiple VBA codes on sheet1
Replies
1
Views
191
skillilea
S
Chris_010101
  • Solved
Simple VBA Code help
2
Replies
12
Views
553
Chris_010101
Chris_010101
G
  • Question
Workbook formulas copied with Sheet references in new Workbook
Replies
0
Views
27
GK039
G

Forum statistics

Threads
1,216,075
Messages
6,128,665
Members
449,462
Latest member
Chislobog

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top