Code works every other time

[Juriemagic]

Hi good people!,

I posted on Mrexcel last week, Aug 14th, have not had any responses. Please, just wondering if someone would be so kind to check this link: http://www.mrexcel.com/forum/excel-questions/875686-code-works-every-other-time.html, otherwise, if preferred I will post everything here as well. Thanx a lot guys!

[Paul_Hossler]

Suggest you post everything here

(and mention the MrExcel cross-post)

[Juriemagic]

I have this code in a sheet (LOG) module:

Private Sub Worksheet_Activate()
Sheets("LOG").Protect
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Sheets("LOG").Unprotect
Dim rCell As Range
Dim rChange As Range
Set rChange = Intersect(Target, Range("C:C"))
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
rCell.Offset(0, 1).Value = Environ$("UserName")
rCell.Offset(0, 2).Value = Date & " " & Time()
Else
'do nothing
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

Private Sub Worksheet_Deactivate()
Sheets("LOG").Unprotect
End Sub

and this code in a button on Sheet2 (UPDATE ROOM)

Sub LogChanges()
' LogChanges Macro
If ActiveSheet.Range("A1").Value = 1 Then Exit Sub
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet.
Set copySheet = Worksheets("Update Room")
Set pasteSheet = Worksheets("LOG")
copySheet.Unprotect
Range("A1").Value = 1
copySheet.Range("E3").Copy
pasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
copySheet.Select
copySheet.Unprotect
Range("A1").Select
copySheet.Protect
pasteSheet.Protect
End Sub

Then this code in Sheet2 module:


Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C3")) Is Nothing Then
ActiveSheet.Unprotect
ActiveSheet.Range("A1") = 2

If I select C3, A1 changes to a 2. When the button is clicked, the code runs by copying the value in E3 and then pasting that value in the LOG sheet in column 3 under the last entry. A1 is also simultaneously changed back to a 1. (The "2" enables the button while the "1" disables it). If I select C3 again, and click the button, I get an error. The next time it will work, and then not, then again, then not...Believe me I have spent this whole day searching, adapting but I cannot get this to work smoothly. I made a small sample workbook, but it was just too big to upload (21kb) on VBA Express. So I did not post there. Please anyone, all help will be accepted with great humility and humbleness. Thank you all kindly...

I posted this thread on MrExcel 10 days ago, and have not received any responses, so I'm trying here. The link is:http://www.mrexcel.com/forum/excel-questions/875686-code-works-every-other-time.html

[snb]

Forget 'protecting' in Excel


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Sheets("LOG").cells(rows.count,3).end(xlup).offset(1).resize(,2)=array(environ(26),now)
End Sub

[Juriemagic]

Hi snb,

Thank you very much for this help, just, I have stared myself blind at this to try and figure out where this must go in, also, must I delete some coding?..sorry for bugging you...

[snb]

Look at the first line: rather obvious I'd say.

[SamT]

Put this code in the ThisWorkbook Module. IT will provide all the Protection that the Regular for of Protect does EXCEPT, the sheets are NOT protected from VBA Code.

Private Sub Workbook_Open()
For Each Sht In Me.Sheets
Sht.Protect UserInterfaceOnly:=True
Next Sht
End Sub

I don't know why you need to click twice to log the change, but I incorporated that process in this code.

Put this code in a standard Module and tie your button on sheet "Update Room" to it.

Sub LogChanges()
' For Help, see: "http://www.vbaexpress.com/forum/showthread.php?53494-Code-works-every-other-time"
' Double Check intent to Ubdate Log
Dim Answer As Variant
Answer = MsgBox(Prompt:="Are you sure you want to update the log at this time?", Buttons:=vbYesNo)
If Answer = vbNo Then Exit Sub
End Block
With Worksheets("LOG").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
.Value = Worksheets("Update Room").Range("E3").Value
.Offset(0, 1).Value = Environ$("UserName")
.Offset(0, 2).Value = Now
End With
End Sub

[Juriemagic]

SamT,

Thank you very much..your assistance is highly appreciated!..Have a good day...

[HiGH_ZeRO]

Hello, I have the same problem with my macro, for some reason for very first time it creates the new sheets only with title row, but after I delete the wrong files and run it again - it works as should be.
Please advise me what is wrong with the code.

Option Explicit

Sub SPLIT_SHEETS()
Application.SheetsInNewWorkbook = 1
Dim key_col As Integer, wb_sh_split As Integer
Dim last_col_descr As String, rng_col_letter As String, sheet_name As String, del_col As String
If ActiveSheet.AutoFilterMode Then
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
Debug.Print ActiveWorkbook.name & ". " & ActiveSheet.name & ". Filter has been cleared"
End If
End If
last_col_descr = "Change Number"
del_col = "KEY"
Cells.Find(what:=last_col_descr, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
rng_col_letter = Split(ActiveCell(1).Address(1, 0), "$")(0)
Cells.Find(what:=del_col, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
key_col = ActiveCell.column
sheet_name = ActiveSheet.name
Debug.Print sheet_name; key_col
wb_sh_split = MsgBox("Do you want to split data to workbooks? Yes to workbooks, No to sheets", vbYesNoCancel, "Please make your choise.")
If wb_sh_split = vbYes Then
wb_sh_split = 1
Call create_subdir
ElseIf wb_sh_split = vbNo Then
wb_sh_split = 2
ElseIf wb_sh_split = vbCancel Then
Exit Sub
End If
Call SPLIT_SHEETS_CORE(rng_col_letter, sheet_name, del_col, key_col, wb_sh_split).
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveWorkbook.Save
End Sub

Function SPLIT_SHEETS_CORE(rng_col_letter As String, sheet_name As String, del_column As String, vcol As Integer, wb_sh_split As Integer)
Dim icol As Long, lr As Long
Dim ws As Worksheet
Dim wb As Workbook
Dim dest_wb As Workbook
Dim titlerow As Long, i As Long
Dim myarr As Variant
Dim new_sh_name As String
Dim strdir As String, title As String
' vcol = 1
' vcol =1, the number 1 is the column number that you want to split the data based on.
strdir = ActiveWorkbook.Path & "\" & "Splitted" & "\"
Set ws = Sheets(sheet_name)
new_sh_name = "Consolidated_file"
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).row
title = "A1:" & rng_col_letter & "1"
titlerow = ws.Range(title).Cells(1).row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCel lTypeConstants))
ws.Columns(icol).Clear
If wb_sh_split = 1 Then
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Debug.Print "1"
With Workbooks.Add
With .Sheets.Add(Before:=.Sheets(1))
.name = new_sh_name
End With
End With
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Sheet1").Delete
Application.DisplayAlerts = True
ActiveWorkbook.SaveAs Filename:=strdir & myarr(i) & ""
Else
Debug.Print "2"
With Workbooks.Add
With .Sheets.Add(After:=Worksheets(Worksheets.Count))
.name = new_sh_name
End With
End With
End If
DoEvents
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(new_sh_name).Range("A1")
Sheets(new_sh_name).Columns.AutoFit
Call match_and_delete(del_column)
ActiveWorkbook.Close SaveChanges:=True
Next
ElseIf wb_sh_split = 2 Then
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).name = new_sh_name
Else
Sheets(new_sh_name).Move After:=Worksheets(Worksheets.Count)
End If
DoEvents
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(new_sh_name).Range("A1")
Sheets(new_sh_name).Columns.AutoFit
Next
End If
ws.AutoFilterMode = False
ws.Activate
End Function

Function create_subdir()
Dim strdir As String
strdir = ActiveWorkbook.Path & "\" & "Splitted" & "\"
If Dir(strdir, vbDirectory) = "" Then
MkDir strdir
Else
End If
End Function

Function match_and_delete(col_name As String)
Dim i As Integer
On Error GoTo ColumnNotExist
i = Application.WorksheetFunction.Match(col_name, Range("A1:AZ1"), 0)
If i > 0 Then
Debug.Print ActiveWorkbook.name & "Column number is " & i
Cells.Find(what:=col_name, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Select
Selection.EntireColumn.Delete
Debug.Print ActiveWorkbook.name & ". Column (" & col_name & ") has been deleted."
End If
Exit Function
ColumnNotExist:
Debug.Print ActiveWorkbook.name & ". Column (" & col_name & ") does not exist and nothing has been done."
Err.Clear
End Function

[Juriemagic]

Hello High ZEro,

unfortunately I am too stupid to help with this, as I was the one who was helped then. I suggest you rather start a new thread, that way the good okes will look at it. This thread had been closed..