Modifying old macro

[HappyLadyToo]

Hi!

I'm trying to use an old macro on a new worksheet but I'm hoping someone can help with the differences. Originally this macro was used to move rows based on an empty cell in a column. Now I'd like to use it to move rows based on a value in a column. The only thing I can think to do is to hard code each values into the macro but the values can change each month. I was considering recording a macro for some of the steps but again, the macro becomes hard coded.

The end result should be each row with the value in column G (in this case a name) should be moved to a new worksheet with that name on the tab.

Please ask if you need clarification.

Option Explicit

Sub moveblank()
    Dim wsCopy As Worksheet
    Dim wsPaste As Worksheet
    Set wsCopy = ThisWorkbook.Sheets("Buyer_Summary")
    Set wsPaste = ThisWorkbook.Sheets("Sheet2")
    Dim lBottomrow As Long
    lBottomrow = wsCopy.Range("A" & wsCopy.Rows.Count).End(xlUp).Row
    Dim rCopy As Range
    Dim rDelete As Range
    Dim c As Range
    Set rCopy = wsCopy.Range("G1:G" & lBottomrow)
    For Each c In rCopy.Cells
        If c = "Joe" Then
            If rDelete Is Nothing Then
                Set rDelete = c.EntireRow
            Else
                Set rDelete = Union(rDelete, c.EntireRow)
            End If
        End If
    Next c
    rDelete.Copy
    lBottomrow = wsPaste.Range("A" & wsPaste.Rows.Count).End(xlUp).Row
    wsPaste.Range("A" & lBottomrow).EntireRow.PasteSpecial (xlPasteAll)
    rDelete.Delete
End Sub

 

[dmt32]

Hi,
not tested but see if following changes to your code go in right direction:

Sub movenames()
    Dim wsCopy As Worksheet, wsPaste As Worksheet
    Dim rCopy As Range, rDelete As Range, c As Range
    Dim lBottomrow As Long
    Dim InputName As Variant
    
    InputName = InputBox("Enter Search Name", "Enter Name")
    If StrPtr(InputName) = 0 Then Exit Sub
    
    Set wsCopy = ThisWorkbook.Sheets("Buyer_Summary")
    Set wsPaste = ThisWorkbook.Sheets("Sheet2")
    
    lBottomrow = wsCopy.Range("G" & wsCopy.Rows.Count).End(xlUp).Row
    
    Set rCopy = wsCopy.Range("G1:G" & lBottomrow)
    For Each c In rCopy.Cells
        If c.Value = InputName Then
            If rDelete Is Nothing Then
                Set rDelete = c
            Else
                Set rDelete = Union(rDelete, c)
            End If
        End If
    Next c
    
    If Not rDelete Is Nothing Then
    rDelete.EntireRow.Copy
    lBottomrow = wsPaste.Range("A" & wsPaste.Rows.Count).End(xlUp).Row
    wsPaste.Range("A" & lBottomrow).PasteSpecial (xlPasteAll)
    rDelete.Delete
    End If
End Sub

Dave

 

[HappyLadyToo]

Just tried this and it works. Excellent! Thanks

 

[Rick Rothstein]

Just tried this and it works. Excellent! Thanks

Question: The next to the last line of code that dmt32 gave you is this...

rDelete.Delete

That only deletes cells in Column G, but you copied the entire row, so did you actually want to delete those entire rows after you copied them? I am thinking the line of code should have been this...

rDelete.EntireRow.Delete

 

[HappyLadyToo]

Rick,

You are correct. I updated the line and it's deleting the rows as it should however now I'm receiving an error and it's on the final End If. It reads Code Execution Has Been Interrupted. If I select Continue, the macro works properly. Do you know why that message is popping up?

 

[HappyLadyToo]

Thank you all for your help. Not worries about the error. I removed the final delete line because I realized I don't need to delete the rows since I'm going to delete the worksheet after everything is copied elsewhere.

 

[Rick Rothstein]

Thank you all for your help. Not worries about the error. I removed the final delete line because I realized I don't need to delete the rows since I'm going to delete the worksheet after everything is copied elsewhere.

If Column G on the Buyer_Summary sheet does not contain any formulas, then I think this more compact code will also work for you (it may even be faster)...

Sub MoveJoe()
  Dim wsPaste As Worksheet, wsCopy As Worksheet
  Const NameToCopy As String = "Rick"
  Set wsPaste = Sheets("Sheet2")
  Set wsCopy = Sheets("Buyer_Summary")
  With Sheets("Buyer_Summary")
    wsCopy.Columns("G").Replace NameToCopy, "#N/A", xlWhole
    On Error GoTo NameNotFound
    wsCopy.Columns("G").SpecialCells(xlConstants, xlErrors).EntireRow.Copy _
                        wsPaste.Cells(Rows.Count, "A").End(xlUp).Offset(1)
  End With
  wsPaste.Columns("G").Replace "#N/A", NameToCopy, xlWhole
  wsCopy.Columns("G").Replace "#N/A", NameToCopy, xlWhole
NameNotFound:
End Sub

 

[HappyLadyToo]

Woo Hoo!! Thanks

 

[HappyLadyToo]

With the help of Rick Rothstein, more research, and little ingenuity, I cobbled together this <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-bottom-style: dotted; border-bottom-color: rgb(0, 0, 0); cursor: help;">VBA</acronym> code.


My workbook (Buyer Summary.xlsm) has three spreadsheets. The first spreadsheet(Buyer_Summary) has private macros to filter one of the other spreadsheets based on where the double click occurs. The end result of this code is to have a workbook for each buyer where the workbook has the same three sheets as Buyer Summary.xlsm with the macros intact. So far, the macro below will separate the buyers into separate sheets within the Buyer Summary workbook but when the export comes up, there is a snag.

What I tried to do is to have the macro open another workbook (TestSummary.xlsm) and copy the named buyer spreadsheet from Buyer Summary.xlsm on to the first sheet of the TestSummary workbook. After the paste happens, I'd like to have the workbook saved as BuyerSummary [Buyer Name].xlsm. What is actually happening is an .xls workbook is created for each buyer - not what I want. An .xlsm workbook is also saved with each buyer's name but the data on the Buyer_Summary sheet is the same buyer in each workbook. The named workbook is not as I'd like it and the location is not where I'd like it.

Bottom line, I'm stuck. Any ideas? If you have a better suggestion than what I have going on, I'll listen.

Also, am I posting my code correctly? I tried to find the directions and could not.

[COLOR=#333333]
Sub SplitWS1()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("G2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Range("G" & i).Value <> .Range("G" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("G" & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True


If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then


    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Buyer_Summary" And sh.Name <> "BaseData" And sh.Name <> "PurchaseSchedule" Then
            sh.Copy
            
           Workbooks.Open Filename:= _
        "C:\Users\u138044\Documents\test files\TestSummary.xlsm", _
        Editable:=True


            Application.CutCopyMode = True
        ChDir _
            "N:\Merch-Global_Supply\Inventory_Planning\Supply_Planning\Regional Purchasing\Buyer Folders\Staci\buyers"
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & BuyerSummary & sh.Name & ".xlsm"
           
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If


End Sub

[/COLOR]