• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 278
  • Last Modified:

Simple VBA Excel Coding

1.      If data in a cell in Column P contains more than 2 characters, then,
                      a.      data in the same row in Column N should be appended with a space and then the contents of the same row in Column O; and
                       b.      data in row in Column O is replaced with data in Column P

Example
      N            O            P
Smith                  Jr.            John

would become
      N            O            P
Smith Jr.                                John            John


2.      I have an indeterminate number of rows. I want the following code to stop running when it gets to a blank row. Right now, it stops at row 500:
Sub Proper_Case()
  Sheets("Data").Select
  Application.ScreenUpdating = False
' Loop to cycle through each cell in the specified range.
   For Each x In Range("K1:Z500")
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      x.Value = Application.Proper(x.Value)
   Next
    Cells.Replace What:="Cv-", Replacement:="CV-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Lvnv", Replacement:="LVNV", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Rgm", Replacement:="RGM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Llc", Replacement:="LLC", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Ii", Replacement:="II", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False
    Application.ScreenUpdating = True
End Sub

3.       I have an indeterminate number of rows. I want to copy the formulas in the first row of columns A-E to each subsequent row that has data in column F.

4.      I want to delete all rows that have the word “Delete” in column B.
0
carlosab
Asked:
carlosab
  • 7
  • 2
1 Solution
 
StephenJRCommented:
Can you post a workbook?
0
 
Arno KosterCommented:
question 1 :
paste as worksheet code in the VBA editor
Sub process_names()

For Row = 1 To UsedRange.Rows.Count
    If Len(Range("N" & Row)) > 2 Then
        Range("N" & Row) = Range("N" & Row) & " " & Range("O" & Row)
        Range("O" & Row) = Range("P" & Row)
    End If
Next Row


End Sub

Open in new window

0
 
Arno KosterCommented:
for the second question :

you can use "usedrange", which determines a bounding box of all cells used in a worksheet

or you can use the following code :
For Each x In Range("K1:Z500")
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      if x.value = "" then exit for
      x.Value = Application.Proper(x.Value)
   Next

Open in new window

0
Learn to develop an Android App

Want to increase your earning potential in 2018? Pad your resume with app building experience. Learn how with this hands-on course.

 
Arno KosterCommented:
as above, use usedrange :

For Each Row In UsedRange.Rows
  '-- the F cell is the 6th cell in a row
  If Row.Cells(6) <> "" Then
    Row.Cells(1).Formula = Range("A1").Formula
    Row.Cells(2).Formula = Range("B1").Formula
    Row.Cells(3).Formula = Range("C1").Formula
    Row.Cells(4).Formula = Range("D1").Formula
    Row.Cells(5).Formula = Range("E1").Formula
  End If

Next Row

Open in new window

0
 
Arno KosterCommented:
and
For Each Row In UsedRange.Rows
  '-- the B cell is the 2nd cell in a row
  If Row.Cells(2) = "Delete" Then
    Row.delete
  End If

Next Row

Open in new window


please note that when deleting a row, all underlying rows move upwards. This can cripple functions relating to cells in this row.
If this is the case, you can try to

row.clear

instead of row.delete.

also : the "Delete" clause is case-sensitive. If you'd rather have a case-insensitive version, use :

if lcase(row.cells(2)) = "delete" then
0
 
carlosabAuthor Commented:
I'm getting a Run-time error '424': Object Required when I try to use the UsedRange function. E.g., for your code for question 1, I pasted this code into the sheet, and try running the macro by itself:

Sub process_names()

For Row = 1 To UsedRange.Rows.Count
    If Len(Range("N" & Row)) > 2 Then
        Range("N" & Row) = Range("N" & Row) & " " & Range("O" & Row)
        Range("O" & Row) = Range("P" & Row)
    End If
Next Row


End Sub
0
 
Arno KosterCommented:
Did you place the macro in a module ?

when used as above, the usedrange is not related to a specific worksheet and thus acts on the worksheet in which the macro is placed. When placed in a module, the code does not have a reference to the worksheet to be used.

so either :

- copy/paste the macro in a worksheet section in the vba editor
or
- add a reference to the required worksheet
eg:
Sub process_names()

With Worksheets("Sheet1")
    For Row = 1 To .UsedRange.Rows.Count
        If Len(.Range("N" & Row)) > 2 Then
            .Range("N" & Row) = .Range("N" & Row) & " " & Range("O" & Row)
            .Range("O" & Row) = .Range("P" & Row)
        End If
    Next Row
End With

End Sub

Open in new window

0
 
Arno KosterCommented:
or in your case : Worksheets("Data")
0
 
carlosabAuthor Commented:
Thanks. Making some progress. But, I still get a Runtime Error - Object required. When I debug, this is what I see. I've put the error location in the macro in Bold below:

Sub CopyFormulas()
    With Worksheets("Data")
        For Each Row In UsedRange.Rows
     '-- the F cell is the 6th cell in a row
          If Row.Cells(6) <> "" Then
            Row.Cells(1).Formula = Range("A1").Formula
            Row.Cells(2).Formula = Range("B1").Formula
            Row.Cells(3).Formula = Range("C1").Formula
            Row.Cells(4).Formula = Range("D1").Formula
            Row.Cells(5).Formula = Range("E1").Formula
          End If
        Next Row
    End With
End Sub

Here is all the Macros in the Module:

Sub Clean()
'
' Macro2 Macro
'

'
    Workbooks.OpenText Filename:= _
        "\\s2\shared\mailings\CVFILE.TXT", Origin:=437, StartRow _
        :=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), Array(2, 2), Array( _
        9, 2), Array(22, 1), Array(52, 1), Array(82, 1), Array(167, 1), Array(187, 1), Array(189, 1) _
        , Array(194, 1), Array(199, 5), Array(207, 9), Array(213, 1), Array(219, 1), Array(225, 1), _
        Array(231, 1), Array(237, 1), Array(243, 1), Array(249, 1), Array(254, 1), Array(265, 1), _
        Array(346, 1), Array(366, 1), Array(368, 1)), TrailingMinusNumbers:=True
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("S:S").Select
    Selection.Cut
    Range("D1").Select
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    Selection.Delete Shift:=xlToLeft
    Columns("J:Q").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:M").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:E").Select
    Selection.Cut
    Range("K1").Select
    ActiveSheet.Paste
    Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=True, Other:=False, FieldInfo:= _
        Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    Columns("M:M").Select
    Selection.Cut
    Range("L1").Select
    Selection.Insert Shift:=xlToRight
    Call CullRows
    Columns("D:D").Select
    Selection.Copy
    Range("A1").Select
    ActiveSheet.Paste
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Columns("A:X").Select
    Selection.Copy
    Windows("DJ Mailings.xlsm").Activate
    Sheets("Data").Select
    Range("F1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Call Proper_Case
    Call CopyFormulas
    Call SortbyDefendant
End Sub
Sub CullRows()
    Dim rng1 As Range
    Dim lngRow As Long
    Application.ScreenUpdating = False
    If [a2] <> vbNullString Then
        Set rng1 = Range([a1], [a1].End(xlDown))
    Else
        Set rng1 = [a1]
    End If
    For lngRow = rng1.Rows.Count To 1 Step -1
        If Not (Cells(lngRow, "A") = "11" Or Cells(lngRow, "A") = "45") Then
            Rows(lngRow).EntireRow.Delete
        Else
            If Left$(Cells(lngRow, "c"), 2) <> "CV" Then Rows(lngRow).EntireRow.Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Sub CopyFormulas()
    With Worksheets("Data")
        For Each Row In UsedRange.Rows
     '-- the F cell is the 6th cell in a row
          If Row.Cells(6) <> "" Then
            Row.Cells(1).Formula = Range("A1").Formula
            Row.Cells(2).Formula = Range("B1").Formula
            Row.Cells(3).Formula = Range("C1").Formula
            Row.Cells(4).Formula = Range("D1").Formula
            Row.Cells(5).Formula = Range("E1").Formula
          End If
        Next Row
    End With
End Sub
Sub Proper_Case()
  Sheets("Data").Select
  Application.ScreenUpdating = False
' Loop to cycle through each cell in the specified range.
   For Each x In Range("A1:Z500")
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      x.Value = Application.Proper(x.Value)
   Next
    Cells.Replace What:="Cv-", Replacement:="CV-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Lvnv", Replacement:="LVNV", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Rgm", Replacement:="RGM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Llc", Replacement:="LLC", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Ii", Replacement:="II", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False
    Application.ScreenUpdating = True
End Sub
Sub process_names()

With Worksheets("Data")
    For Row = 1 To UsedRange.Rows.Count
        If Len(Range("N" & Row)) > 2 Then
            Range("N" & Row) = Range("N" & Row) & " " & Range("O" & Row)
            Range("O" & Row) = Range("P" & Row)
        End If
    Next Row

End With

End Sub
Sub SortbyDefendant()
'
' Macro4 Macro
'

'
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("O:O"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").Sort
        .SetRange Range("A:AA")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("o:o").Select

End Sub
Sub SortByMagistrate()
'
' Macro5 Macro
'

'
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("C:C"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").Sort
        .SetRange Range("A:AA")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Sub MoveNamesAndPrepForCallsToMagistrate()
'
' Macro9 Macro
'

    Sheets("Data").Select
    Columns("Q:R").Select
    Application.CutCopyMode = False
    Selection.Cut
    Range("I1").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Selection.ColumnWidth = 37.43
    Range("K1:K40").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
    Range("I30:K30").Select
    Range("K30").Activate
    ActiveWindow.ScrollColumn = 1
    Columns("E:E").Select
    Selection.EntireColumn.Hidden = True
    Columns("G:G").Select
    Selection.EntireColumn.Hidden = True
End Sub

0
 
Arno KosterCommented:
Almost there, you made a typo :

the code

 with worksheets("data")
    .usedrange [...]
   .cells[...]
end with

translates to

worksheets("data").usedrange [...]
worksheets("data").cells[...]

but only if you include the leading dot (".")

otherwise is would translate to

worksheets("data")usedrange instead of  worksheets("data").usedrange
0

Featured Post

Take Control of Web Hosting For Your Clients

As a web developer or IT admin, successfully managing multiple client accounts can be challenging. In this webinar we will look at the tools provided by Media Temple and Plesk to make managing your clients’ hosting easier.

  • 7
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now