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-q...ther-time.html, otherwise, if preferred I will post everything here as well. Thanx a lot guys!
Suggest you post everything here
(and mention the MrExcel cross-post)
---------------------------------------------------------------------------------------------------------------------
Paul
Remember: Tell us WHAT you want to do, not HOW you think you want to do it
1. Use [CODE] ....[/CODE ] Tags for readability
[CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
2. Upload an example
Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
3. Mark the thread as [Solved] when you have an answer
Thread Tools (on the top right corner, above the first message)
4. Read the Forum FAQ, especially the part about cross-posting in other forums
http://www.vbaexpress.com/forum/faq...._new_faq_item3
I have this code in a sheet (LOG) module:
and this code in a button on Sheet2 (UPDATE ROOM)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
Then this code in Sheet2 module: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
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...Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("C3")) Is Nothing Then ActiveSheet.Unprotect ActiveSheet.Range("A1") = 2
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-q...ther-time.html
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
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...
Look at the first line: rather obvious I'd say.
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.
I don't know why you need to click twice to log the change, but I incorporated that process in this code.Private Sub Workbook_Open() For Each Sht In Me.Sheets Sht.Protect UserInterfaceOnly:=True Next Sht End Sub
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
I expect the student to do their homework and find all the errrors I leeve in.
Please take the time to read the Forum FAQ
SamT,
Thank you very much..your assistance is highly appreciated!..Have a good day...
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(xlCellTypeConstants)) 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
Hello High ZEro,Originally Posted by 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..
Posting Permissions
