Macro forcing values into specific cells

[dougkale]

I m creating a template that users will be using for data entry. The worksheet (There will be only one) has to have very specific column headings due to constraints of further processing being done to the file by a separate application. Because these demands are so specific I am writing some data cleansing steps that correct common errors. First of them is simple forcing the column headers to be what they need to be.

To do this I have created a macro that runs before save. So that when they save the file common errors are corrected.

The problem I am having is that if the file is saved, then additional data is entered, or even if its not, but the file is subsequently saved, the headers are rewritten and not always in the first row of the sheet.

The code I am using seems pretty straight forward:

Range("A1").Value = "Header1"
Range("B1").Value = "Header2"
Range("C1").Value = "Header3"
Range("D1").Value = "Header4"
Range("E1").Value = "Header5"
Range("F1").Value = "Header6"
Range("G1").Value = "Header7"
Range("H1").Value = "Header8"
Range("I1").Value = "Header9"
Range("J1").Value = "Header10"
Range("K1").Value = "Header11"
Range("L1").Value = "Header12"


The first time the file is saved and the event is triggered the headers insert properly. Subsequent saves of the file throws them usually into unpredictable locations.

 

[oldbrewer]

what if you use (for the first line) cells(1,1)="Header1"

 

[Rick Rothstein]

The code I am using seems pretty straight forward:

Range("A1").Value = "Header1"
Range("B1").Value = "Header2"
Range("C1").Value = "Header3"
Range("D1").Value = "Header4"
Range("E1").Value = "Header5"
Range("F1").Value = "Header6"
Range("G1").Value = "Header7"
Range("H1").Value = "Header8"
Range("I1").Value = "Header9"
Range("J1").Value = "Header10"
Range("K1").Value = "Header11"
Range("L1").Value = "Header12"


The first time the file is saved and the event is triggered the headers insert properly. Subsequent saves of the file throws them usually into unpredictable locations.

You are going to have to explain this in more detail.The code you posted, as written, cannot place the headers anywhere other then the range A1:L1 on the active sheet no matter how many times it is executed.

 

[dougkale]

There is additional processing going on. I will provide as I am guessing that the problem is likely occurring in there some where:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Exit Sub
Dim i As Long
Dim DelRange As Range
Dim LastRow As Long
Range("A1").Value = "Header1"
Range("B1").Value = "Header2"
Range("C1").Value = "Header3"
Range("D1").Value = "Header4"
Range("E1").Value = "Header5"
Range("F1").Value = "Header6"
Range("G1").Value = "Header7"
Range("H1").Value = "Header8"
Range("I1").Value = "Header9"
Range("J1").Value = "Header10"
Range("K1").Value = "Header11"
Range("L1").Value = "Header12"


'Delete blank cells

On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 10000
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Rows(i)
Else
Set DelRange = Union(DelRange, Rows(i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True

Dim d As Object
Dim a As Variant

Set d = CreateObject("Scripting.Dictionary")
a = Range("C2", Range("D" & Rows.Count).End(xlUp)).Value
For i = 1 To UBound(a)
d(a(i, 1)) = d(a(i, 1)) + a(i, 2)
Next i
Range("M3:N3").Resize(d.Count).Value = Application.Transpose(Array(d.keys, d.items))


' Dim LastRow As Long
LastRow = Range("M" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow

Select Case Range("M" & i).Value
Case 1,2,3,4,5
Range("o" & i).Value = "C"
Case 6,7,8,9,10
Range("o" & i).Value = "D"
Case Else
Range("o" & i).Value = "I"
End Select

Next i
Set d = CreateObject("Scripting.Dictionary")
d.comparemode = 1
d("C") = 0
d("D") = 0
a = Range("N3", Range("O" & Rows.Count).End(xlUp)).Value
For i = 1 To UBound(a)
d(a(i, 2)) = Round(d(a(i, 2)) + a(i, 1), 2)
Next i
d("T") = Round(d("C") - d("D"), 2)
Range("N" & Rows.Count).End(xlUp).Offset(2).Resize(3, 2).Value = Application.Transpose(Array(d.items, d.keys))

Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub

 

[dougkale]

Please excuse the formatting. All was indented for readability when I pasted it . . . .

 

[Joe4]

Please excuse the formatting. All was indented for readability when I pasted it . . . .

If you use Code tags around your code, it will maintain all indenting and spacing.
It is one of the icons in the Editor.
See: https://www.mrexcel.com/forum/board-announcements/515787-how-post-your-vba-code.html

 

[dougkale]

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Exit Sub
    Dim i As Long
    Dim DelRange As Range
    Dim LastRow As Long
'Correct Headers
    Range("A1").Value = "Header1"
    Range("B1").Value = "Header2"
    Range("C1").Value = "Header3
    Range("D1").Value = "Header4"
    Range("E1").Value = "Header5"
    Range("F1").Value = "Header6"
    Range("G1").Value = "Header7"
    Range("H1").Value = "Header8"
    Range("I1").Value = "Header9"
    Range("J1").Value = "Header10"
    Range("K1").Value = "Header11"
    Range("L1").Value = "Header12"
'Delete blank cells
   
   On Error GoTo Whoa
    Application.ScreenUpdating = False
    For i = 1 To 10000
        If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
            If DelRange Is Nothing Then
                Set DelRange = Rows(i)
            Else
                Set DelRange = Union(DelRange, Rows(i))
            End If
        End If
    Next i
    If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
    Application.ScreenUpdating = True
'Sort rows by TC
Range("c2").CurrentRegion.Sort key1:=Range("c2"), order1:=xlAscending, Header:=xlGuess
   
  Dim d As Object
  Dim a As Variant
 
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("C2", Range("D" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) + a(i, 2)
  Next I
  Range("M3:N3").Resize(d.Count).Value = Application.Transpose(Array(d.keys, d.items))
  
  
    LastRow = Range("M" & Rows.Count).End(xlUp).Row
    For i = 3 To LastRow
        
 Select Case Range("M" & i).Value
     Case1,2,3,4,5
        Range("o" & i).Value = "C"
    Case 6,7,8,9
        Range("o" & i).Value = "D"
    Case Else
        Range("o" & i).Value = "I"
 End Select
        
Next i
  Set d = CreateObject("Scripting.Dictionary")
  d.comparemode = 1
  d("C") = 0
  d("D") = 0
  a = Range("N3", Range("O" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    d(a(i, 2)) = Round(d(a(i, 2)) + a(i, 1), 2)
  Next I
  d("T") = Round(d("C") - d("D"), 2)
  Range("N" & Rows.Count).End(xlUp).Offset(2).Resize(3, 2).Value = Application.Transpose(Array(d.items, d.keys))
    
    
    Dim LR      As Long
    Dim rng     As Range
    Dim strMsg  As String
        
    With Sheets("Sheet1")
        LR = .Cells(.Rows.Count, 15).End(xlUp).Row
        Set rng = .Cells(1, 15).Resize(LR).Find(what:="T", LookIn:=xlValues, lookat:=xlWhole)
        strMsg = "Balances"
        If rng.Offset(, -1).Value <> 0 Then strMsg = "The Block does not balance " & rng.Offset(, -1).Value
                
        Set rng = Nothing
    End With
    
    If strMsg <> "Balances" Then MsgBox strMsg, vbOKOnly, "WARNING"
    '& IIf(InStr(strMsg, "not"), "Not ", "") & "Found"
    
    
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

 

[Joe4]

Without having the data file to process the code against, I think it is going to be a bit difficult to figure out what might be going on.

I would recommend stepping through the code while watching to see what is happening on the sheet to see when things appear to go haywire.
If you have two monitors, this is easy. Just put the VB Editor on one, and your worksheet on the other. Otherwise, re-size your VBA Editor screen down to about 1/4 size of the screen so you can easily see both at the same time. Then step into your code, and press F8 to process one step at a time and watch what happens to your sheet.

If that does not immediately reveal the issue, and you have a ton of loops to go through, add Break Points at certain points in your code, then you can use F5 to process everything up to the Break Point, and then F5 to repeat up until the next Break Point, etc.

 

[dougkale]

I did as you suggested and the line that seems to be sending everything awry is:

Range("c2").CurrentRegion.Sort key1:=Range("c2"), order1:=xlAscending, Header:=xlGuess

The first time through it does fine however somehow the second time the file is saved it includes the headers.

 

[Joe4]

If you do not want headers, then change this argument:

[COLOR=#333333]Header:=xlGuess

to this:
[/COLOR]

[COLOR=#333333]Header:=xlNo[/COLOR]

"Guess" means let Excel try to determine is headers should be there or not, instead of explicitly saying "Yes" or "No".