Editing Post with [VBA] tags

Soemt text
Correct some text and save
[vba]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[/vba]

copy and paste code into new tags, code format looks good on paste
[VBA]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 [/VBA]

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
[VBA]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[/VBA]

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

Quote:

Originally Posted by SamT

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.

[vba]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 [/vba]

Quote:

Originally Posted by SamT

[vba]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
[/vba]

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

Hmmmm?

Private Sub ColumnName()
      Dim Cell$
      Cell = ActiveCell.Address
      If Right(Left(Cell, 3), 1) = "$" Then
            Msg Box "Column selected is " & Right(Left(Cell, 2), 1)
      Else
            Msg Box "Column selected is " & Right(Left(Cell, 3), 2)
      End If
End Sub

Code:

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

[vba]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

[/vba]