View Full Version : Editing Post with [VBA] tags
Soemt text
Correct some text and save
Sub Button1_Click()
Application.ScreenUpdating = False
x = 2
With Worksheets("Sheet1")
Do While .Cells(x, 4) <> ""
'When value in Column "D" changes
If Cells(x, 4) <> Cells(x - 1, 4) Then
If Sheets(Cells(x, 4)) Is Nothing Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cells(x, 4) 'Sheets(Sheets.Count).Name = isometry
End If
End If
'For every cell in Column "D"
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Cells(x, 4)).Cells(33, 2) = Sheet1.Cells(x, 4) 'isometry
Sheets(Cells(x, 4)).Cells(33, 28) = Sheet1.Cells(x, 32) 'date
End If
x = x + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
copy and paste code into new tags, code format looks good on paste
Sub Button1_Click()
Application.ScreenUpdating = False
x = 2 With Worksheets("Sheet1")
Do While .Cells(x, 4) <> ""
'When value in Column "D" changes
If Cells(x, 4) <> Cells(x - 1, 4) Then
If Sheets(Cells(x, 4)) Is Nothing Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cells(x, 4)
'Sheets(Sheets.Count).Name = isometry
End If
End If
'For every cell in Column "D"
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Cells(x, 4)).Cells(33, 2) = Sheet1.Cells(x, 4)
'isometry
Sheets(Cells(x, 4)).Cells(33, 28) = Sheet1.Cells(x, 32)
'date
End If
x = x + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Previous post was righ click in cod section, CtrlA + CtrlV,
This post is carefully select only code in section and paste into new VBA tags.
AHA! :devil2: Code text is still colored. Will try to remove all text formatting before submitting
Sub Button1_Click()
Application.ScreenUpdating = False
x = 2
With Worksheets("Sheet1")
Do While .Cells(x, 4) <> ""
'When value in Column "D" changes
If Cells(x, 4) <> Cells(x - 1, 4) Then
If Sheets(Cells(x, 4)) Is Nothing Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cells(x, 4)
'Sheets(Sheets.Count).Name = isometry
End If
End If
'For every cell in Column "D"
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Cells(x, 4)).Cells(33, 2) = Sheet1.Cells(x, 4)
'isometry Sheets(Cells(x, 4)).Cells(33, 28) = Sheet1.Cells(x, 32)
'date
End If
x = x + 1 Loop
End With
Application.ScreenUpdating = True
End Sub
This time I will paste without VBA tags
Sub Button1_Click()
Application.ScreenUpdating = False
x = 2
With Worksheets("Sheet1")
Do While .Cells(x, 4) <> ""
'When value in Column "D" changes
If Cells(x, 4) <> Cells(x - 1, 4) Then If Sheets(Cells(x, 4)) Is Nothing Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cells(x, 4)
'Sheets(Sheets.Count).Name = isometry
End If
End If
'For every cell in Column "D"
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Cells(x, 4)).Cells(33, 2) = Sheet1.Cells(x, 4)
'isometry
Sheets(Cells(x, 4)).Cells(33, 28) = Sheet1.Cells(x, 32)
'date
End If
x = x + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Aussiebear
04-15-2013, 03:07 AM
Previous post was righ click in cod section, CtrlA + CtrlV,
This post is carefully select only code in section and paste into new VBA tags.
AHA! :devil2: Code text is still colored. Will try to remove all text formatting before submitting
[
Highlight the text that you are posting and click on the Text button ( to the left of the Select font type box) and see what happens
Thanks, Mate, I'll try that.
<font face=Courier New><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Worksheet_BeforeRightClick(<SPAN style="color:#00007F">ByVal</SPAN> Target <SPAN style="color:#00007F">As</SPAN> Range, Cancel <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>)<br> <SPAN style="color:#007F00">'Must first double click one cell in column "A" for this to run</SPAN><br>  <br>  <SPAN style="color:#00007F">If</SPAN> Target <> ActiveCell <SPAN style="color:#00007F">Then</SPAN> <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br>  Cancel = <SPAN style="color:#00007F">True</SPAN><br>  <br>  <SPAN style="color:#00007F">With</SPAN> Target.EntireRow.Interior<br>    <SPAN style="color:#00007F">If</SPAN> .ColorIndex = 6 <SPAN style="color:#00007F">Then</SPAN><br>      .ColorIndex = xlColorIndexNone<br>    <SPAN style="color:#00007F">Else</SPAN><br>      .ColorIndex = 6<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>  <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'Must first double click one cell in column "A" for this to run
If Target <> ActiveCell Then Exit Sub
Cancel = True
With Target.EntireRow.Interior
If .ColorIndex = 6 Then
.ColorIndex = xlColorIndexNone
Else
.ColorIndex = 6
End If
End With
End Sub
<font face=Courier New><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Worksheet_BeforeRightClick(<SPAN style="color:#00007F">ByVal</SPAN> Target <SPAN style="color:#00007F">As</SPAN> Range, Cancel <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>)<br> <SPAN style="color:#007F00">'Must first double click one cell in column "A" for this to run</SPAN><br>  <br>  <SPAN style="color:#00007F">If</SPAN> Target <> ActiveCell <SPAN style="color:#00007F">Then</SPAN> <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br>  Cancel = <SPAN style="color:#00007F">True</SPAN><br>  <br>  <SPAN style="color:#00007F">With</SPAN> Target.EntireRow.Interior<br>    <SPAN style="color:#00007F">If</SPAN> .ColorIndex = 6 <SPAN style="color:#00007F">Then</SPAN><br>      .ColorIndex = xlColorIndexNone<br>    <SPAN style="color:#00007F">Else</SPAN><br>      .ColorIndex = 6<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>  <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>
Aussiebear
07-15-2013, 06:42 PM
Hmmmm?
Private Sub ColumnName()
      Dim Cell$
      Cell = ActiveCell.Address
      If Right(Left(Cell, 3), 1) = "$" Then
            MsgBox "Column selected is " & Right(Left(Cell, 2), 1)
      Else
            MsgBox "Column selected is " & Right(Left(Cell, 3), 2)
      End If
End Sub
Option Explicit
Function GetRecordNumber(CaseNumber) As Long
'Returns 0 if CaseNumber Not Found
'Returns Row Number of CaseNumber If Found
'Assumes that each Case Number only occurs once on the sheet
Dim NextRow As Long 'Speedy search
Dim X As Range
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Set X = Range("C2:C" & NextRow).Find(CaseNumber)
If X Is Nothing Then
GetRecordNumber = 0
Else
GetRecordNumber = X.Row
End If
End Function
Function GetNextRecordNumber() As Long
GetNextRecordNumber = Range("A" & Rows.Count).End(xlUp).Row + 1
End Function
Function GetLastFieldNum() As Long
'Assumes Intake Table has empty column to right side
GetLastFieldNum = Range("A1").End(xlToRight).Column
End Function
Function SetColors(RecordNumber)
'Assumes there is an empty column at the right of the Intake table
If RecordNumber = "" Then Exit Function
Dim LastCol As Long
Dim ICI As Long 'Interior ColorIndex #
Dim FCI As Long 'Font ColorIndex #
Const DefaultICI As Long = 16
Const DefaultFCI As Long = -4105
LastCol = Range("A1").End(xlToRight).Column
Select Case UCase(Range("A" & RecordNumber).Value)
Case "OPEN": ICI = 16 'Dark Grey
Case "SERVE": ICI = 10 'Green
Case "BAD ADDRESS": ICI = 46 'Orange
Case "RE-DATE": ICI = 44 'Dark Yellow
Case "STOP SERVE": ICI = 30 'Dark red
FCI = 2 'White
Case "RTO": ICI = 13 'Purple
FCI = 2 'White
Case Else
ICI = DefaultICI
FCI = DefaultFCI
End Select
With Range("A" & RecordNumber).Resize(, LastCol)
.Interior.ColorIndex = ICI
.Font.ColorIndex = FCI
End With
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
If DesignMode Then Exit Sub
'This should be done by Form input box validation thus allowing proper names to be
'in Familiar format (Proper Name) and making select values stand out by all UPPERCASE
Dim Cel As Range 'Cell is too similar to a VBA Key word (Cells)
On Error Resume Next
Application.EnableEvents = False
For Each Cel In Target
Cel = UCase(Cel)
Next
Application.EnableEvents = True
End Sub
Sub Button1_Click()
Application.ScreenUpdating = False
x = 2
With Worksheets("Sheet1")
Do While .Cells(x, 4) <> ""
'When value in Column "D" changes
If Cells(x, 4) <> Cells(x - 1, 4) Then
If Sheets(Cells(x, 4)) Is Nothing Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cells(x, 4) 'Sheets(Sheets.Count).Name = isometry
End If
End If
'For every cell in Column "D"
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Cells(x, 4)).Cells(33, 2) = Sheet1.Cells(x, 4) 'isometry
Sheets(Cells(x, 4)).Cells(33, 28) = Sheet1.Cells(x, 32) 'date
End If
x = x + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2025 vBulletin Solutions Inc. All rights reserved.