Copy and pasting marco with a specific value

[zoey]

Hello, I'm trying to copy and paste specific information from one sheet to another by a name value.

Example:
A B C D
1 mitchell 100 Jun 1 purchase
2 mitchell 200 jul 2 purchase
3 smith 50 jun 1 purchase
4 john 900 jul 2 purchase

So I have multiple sheets with those names within the workbook and i want to copy and paste just the contents of mitchell into another work sheet called mitchell but each month the amount of lines varies. The copying and pasting formula is easy but when the information varies in amount of rows each month I need for it to lookup a specific word.

 

[Marc L]

Hi,​

​

use an advanced filter, easy with the help of the Macro Recorder …​

​

 

[Logit]

.

Option Explicit
Sub CreateSheets()

    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

        Set RngBeg = Worksheets("Sheet1").Range("A2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)

        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]mmm;@"))

                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]mmm;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True

MakeHeaders
End Sub

Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub

Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error Resume Next
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Dim ans As String
Dim ans2 As String

NoVisi

    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 1).Value
    ans2 = Format(ans, "[$-409]mmm;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Sheets(ans2).Columns("A:C").AutoFit
    Next
    

Visi

Application.ScreenUpdating = True

Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
Exit Sub

Application.ScreenUpdating = True

End Sub

Sub NoVisi()
Dim CommandButton1 As Object

CommandButton1.Visible = False

End Sub

Sub Visi()
Dim CommandButton1 As Object

CommandButton1.Visible = True
End Sub