Consulting

Results 1 to 13 of 13

Thread: Editing Post with [VBA] tags

  1. #1
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location

    Exclamation 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]
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  2. #2
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    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]
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  3. #3
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    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! 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]
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  4. #4
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    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
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  5. #5
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    3,838
    Location
    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! 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
    Remember To Do the Following....
    Use tags when posting code to the thread,
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  6. #6
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    Thanks, Mate, I'll try that.
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  7. #7
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    [vba]<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>[/vba]
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  8. #8
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    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]
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  9. #9
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    <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>
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  10. #10
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    3,838
    Location
    Hmmmm?
    Remember To Do the Following....
    Use tags when posting code to the thread,
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  11. #11
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    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;Msg Box "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;Msg Box "Column selected is " & Right(Left(Cell, 3), 2)
    &#160;&#160;&#160;&#160;&#160;&#160;End If
    End Sub
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  12. #12
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    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
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  13. #13
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,116
    Location
    [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]
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •