PDA

View Full Version : Editing Post with [VBA] tags



SamT
04-11-2013, 06:19 PM
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

SamT
04-11-2013, 06:21 PM
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

SamT
04-11-2013, 06:32 PM
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

SamT
04-11-2013, 06:34 PM
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

SamT
04-17-2013, 10:08 AM
Thanks, Mate, I'll try that.

SamT
07-15-2013, 08:10 AM
<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>&#160;&#160;<br>&#160;&#160;<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>&#160;&#160;Cancel = <SPAN style="color:#00007F">True</SPAN><br>&#160;&#160;<br>&#160;&#160;<SPAN style="color:#00007F">With</SPAN> Target.EntireRow.Interior<br>&#160;&#160;&#160;&#160;<SPAN style="color:#00007F">If</SPAN> .ColorIndex = 6 <SPAN style="color:#00007F">Then</SPAN><br>&#160;&#160;&#160;&#160;&#160;&#160;.ColorIndex = xlColorIndexNone<br>&#160;&#160;&#160;&#160;<SPAN style="color:#00007F">Else</SPAN><br>&#160;&#160;&#160;&#160;&#160;&#160;.ColorIndex = 6<br>&#160;&#160;&#160;&#160;<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>&#160;&#160;<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>&#160;&#160;&#160;&#160;<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

SamT
07-15-2013, 08:13 AM
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

SamT
07-15-2013, 08:15 AM
<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>&#160;&#160;<br>&#160;&#160;<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>&#160;&#160;Cancel = <SPAN style="color:#00007F">True</SPAN><br>&#160;&#160;<br>&#160;&#160;<SPAN style="color:#00007F">With</SPAN> Target.EntireRow.Interior<br>&#160;&#160;&#160;&#160;<SPAN style="color:#00007F">If</SPAN> .ColorIndex = 6 <SPAN style="color:#00007F">Then</SPAN><br>&#160;&#160;&#160;&#160;&#160;&#160;.ColorIndex = xlColorIndexNone<br>&#160;&#160;&#160;&#160;<SPAN style="color:#00007F">Else</SPAN><br>&#160;&#160;&#160;&#160;&#160;&#160;.ColorIndex = 6<br>&#160;&#160;&#160;&#160;<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>&#160;&#160;<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>&#160;&#160;&#160;&#160;<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

Aussiebear
07-15-2013, 06:42 PM
Hmmmm?

SamT
07-23-2013, 05:44 AM
Private Sub ColumnName()
&#160;&#160;&#160;&#160;&#160;&#160;Dim Cell$
&#160;&#160;&#160;&#160;&#160;&#160;Cell = ActiveCell.Address
&#160;&#160;&#160;&#160;&#160;&#160;If Right(Left(Cell, 3), 1) = "$" Then
&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;MsgBox "Column selected is " & Right(Left(Cell, 2), 1)
&#160;&#160;&#160;&#160;&#160;&#160;Else
&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;&#160;MsgBox "Column selected is " & Right(Left(Cell, 3), 2)
&#160;&#160;&#160;&#160;&#160;&#160;End If
End Sub

SamT
07-26-2013, 07:16 PM
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

SamT
09-01-2013, 05:15 PM
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