Solved Need to combine 2 macros into one

March 7, 2013 at 06:30:12
Specs: Windows XP
Need to combine 2 macros into one


Sub OneColumn()

    Columns("D:D").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("O:O").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("E:Q").Select
    Selection.Delete Shift:=xlToLeft
    Columns("F:M").Select
    Selection.Delete Shift:=xlToLeft
    Range("D7").Select
    MatchKeywords
End Sub

Public Sub MatchKeywords()
  Const keySheet As String = "keywords"
  Const dataSheet As String = "data"

  Dim rngKeywords As Excel.Range
  Dim rngSearch As Excel.Range
  Dim rngData As Excel.Range
  Dim rng As Excel.Range
  
  Dim calcs As Excel.XlCalculation
  
  Dim wshResult As Excel.Worksheet
  Dim strSearch As String
  Dim firstFind As String
  
  Application.ScreenUpdating = False
  calcs = Application.Calculation
  Application.Calculation = Excel.xlManual
  
  With ThisWorkbook.Worksheets(keySheet)
    Set rngKeywords = .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1))
  End With
  
  With ThisWorkbook.Worksheets(dataSheet)
    Set rngData = Intersect(.Columns(1), .UsedRange)
  End With
  
  For Each rng In rngKeywords.Cells
    strSearch = rng.Value
    
    With ThisWorkbook.Worksheets
      Set wshResult = .Add(After:=.Item(.Count))
      wshResult.Range("A1").Value = "Legal Entity"
      wshResult.Range("B1").Value = "Voucher Number"
      wshResult.Range("C1").Value = "Account"
      wshResult.Range("D1").Value = "Name"
      wshResult.Range("E1").Value = "Date"
      wshResult.Range("F1").Value = "Balance"
      wshResult.Range("G1").Value = "0-30 Days"
      wshResult.Range("H1").Value = "31-60 Days"
      wshResult.Range("I1").Value = "61-90 Days"
      wshResult.Range("J1").Value = "91-120 Days"
      wshResult.Range("K1").Value = "Over 120 Days"
      wshResult.Range("L1").Value = "Comments"
      wshResult.Range("M1").Value = "Actions"
      
    End With
    
    wshResult.Name = Left$(strSearch, 24)
    
    Set rngSearch = rngData.Find(strSearch, , Excel.xlFormulas, Excel.xlPart)
    
    If Not rngSearch Is Nothing Then
      firstFind = rngSearch.Address
      Do
        Intersect(rngSearch.EntireRow, rngSearch.Parent.UsedRange).Copy _
                            wshResult.Cells(wshResult.UsedRange.Rows.Count + 1, 1)
        Set rngSearch = rngData.Find(strSearch, rngSearch)
      Loop While Not rngSearch Is Nothing And StrComp(rngSearch.Address, firstFind) <> 0
    End If
  Next rng
  
  Application.ScreenUpdating = True
  Application.Calculation = calcs
End Sub


See More: Need to combine 2 macros into one

Report •


#1
March 7, 2013 at 08:32:38
✔ Best Answer
Well to start with, your first macro, OneColumn, can be shortened considerably.

Rarely, if ever, is there a need to select a range in Excel before performing an action on it. In the vast majority of cases, you can perfrom the action directly on the object within VBA.

Feel free to test this, but I believe it does exactly what your OneColumn macro does:


Sub OneColumn()

    Columns("D:D").Cut
    Columns("A:A").Insert Shift:=xlToRight
    Columns("O:O").Cut
    Columns("B:B").Insert Shift:=xlToRight
    Columns("E:Q").Delete Shift:=xlToLeft
    Columns("F:M").Delete Shift:=xlToLeft
   
    MatchKeywords
End Sub

As far as combining the macros, since it appears that you are performing the OneColumn actions first, you should be able to simply copy all of those "Columns" lines into the MatchKeywords macro as the first set of instructions. The only thing I'm not sure of is which sheet you are doing all the column movement in.

It seems to me that you should be able do something like the following, however I strongly suggest that you test this in a backup copy of the workbook in case things go terribly wrong.

Public Sub MatchKeywords()
  Const keySheet As String = "keywords"
  Const dataSheet As String = "data"

  Dim rngKeywords As Excel.Range
  Dim rngSearch As Excel.Range
  Dim rngData As Excel.Range
  Dim rng As Excel.Range
  
  Dim calcs As Excel.XlCalculation
  
  Dim wshResult As Excel.Worksheet
  Dim strSearch As String
  Dim firstFind As String
  
  Application.ScreenUpdating = False

'*** Begin Copied Code ***

   With ThisWorkbook.Worksheets(*******) '<--- Place a worksheet name or number here
       Columns("D:D").Cut
       Columns("A:A").Insert Shift:=xlToRight
       Columns("O:O").Cut
       Columns("B:B").Insert Shift:=xlToRight
       Columns("E:Q").Delete Shift:=xlToLeft
       Columns("F:M").Delete Shift:=xlToLeft
   End With

'*** End Copied Code ***

  calcs = Application.Calculation
  Application.Calculation = Excel.xlManual
  
  With ThisWorkbook.Worksheets(keySheet)
    Set rngKeywords = .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1))
  End With
  
  With ThisWorkbook.Worksheets(dataSheet)
    Set rngData = Intersect(.Columns(1), .UsedRange)
  End With
  
  For Each rng In rngKeywords.Cells
    strSearch = rng.Value
    
    With ThisWorkbook.Worksheets
      Set wshResult = .Add(After:=.Item(.Count))
      wshResult.Range("A1").Value = "Legal Entity"
      wshResult.Range("B1").Value = "Voucher Number"
      wshResult.Range("C1").Value = "Account"
      wshResult.Range("D1").Value = "Name"
      wshResult.Range("E1").Value = "Date"
      wshResult.Range("F1").Value = "Balance"
      wshResult.Range("G1").Value = "0-30 Days"
      wshResult.Range("H1").Value = "31-60 Days"
      wshResult.Range("I1").Value = "61-90 Days"
      wshResult.Range("J1").Value = "91-120 Days"
      wshResult.Range("K1").Value = "Over 120 Days"
      wshResult.Range("L1").Value = "Comments"
      wshResult.Range("M1").Value = "Actions"
      
    End With
    
    wshResult.Name = Left$(strSearch, 24)
    
    Set rngSearch = rngData.Find(strSearch, , Excel.xlFormulas, Excel.xlPart)
    
    If Not rngSearch Is Nothing Then
      firstFind = rngSearch.Address
      Do
        Intersect(rngSearch.EntireRow, rngSearch.Parent.UsedRange).Copy _
                            wshResult.Cells(wshResult.UsedRange.Rows.Count + 1, 1)
        Set rngSearch = rngData.Find(strSearch, rngSearch)
      Loop While Not rngSearch Is Nothing And StrComp(rngSearch.Address, firstFind) <> 0
    End If
  Next rng
  
  Application.ScreenUpdating = True
  Application.Calculation = calcs
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#2
March 8, 2013 at 00:34:04
Voila

Ohhh you're a genius man. I'm still a newbie and trying to find my feet with VBA.

Thank you

edited by moderator: New question snipped...


Report •
Related Solutions


Ask Question