Move matching rows to existing sheets

[nero6014]

Hello, I have used the below code to create new worksheets based on unique values in column A, I now need to paste data to those sheets based on the same column A. I have seen many examples of how to do it in one operation but I really need to do it in separate operations. Creating the sheets would be done once per campaign but clearing the sheets and pasting the header row and data to them would be done daily. Can the same operation be used to identify what's in column A and then paste the entire row to the sheet with the matching name? Column A has Question numbers in the format of Q01 and so on and the sheets are named the same. The amount of rows and columns will vary by campaign so it needs to be variable. Thanks in advance for any help you can give me. Ed

Sub CreateSheets()
Dim dicKey, dicValues, data, lastrow As Long
Dim i As Long, ws As Worksheet, wsDest As Worksheet
Set ws = ActiveSheet
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
data = Range("A2:A" & lastrow) ' load data into variable
With CreateObject("scripting.dictionary")
For i = 1 To UBound(data)
If .Exists(data(i, 1)) = False Then
dicKey = data(i, 1) 'set the key
dicValues = data(i, 1) 'set the value for data to be stored
.Add dicKey, dicValues
Set wsDest = Sheets.Add(After:=Sheets(Worksheets.Count))
wsDest.Name = data(i, 1)
Sheets(data(i, 1)).Cells(1, 1).Value = ws.Cells(i + 1, 2).Value
End If
Next i
End With
End Sub

[mana]

Please post a sample book with small data and your expected results.

[nero6014]

Book1.xlsxA1, A2 and A3 will always be empty, there can be from 150 to 250 columns and well over 2000 rows. The Sheets have already been created by code posted above, I just need to copy the header and rows using column A to match the sheets already created. Hope this is clearer?

[mana]

I can not understand what you want to do.
?????

Option Explicit


Sub CreateSheets()
    Dim data, lastrow As Long
    Dim i As Long, ws As Worksheet, wsDest As Worksheet
    Dim shn As String
    
    Set ws = ActiveSheet
    lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
     data = ws.Range("A2:B" & lastrow) ' load data into variable
    
    For i = 1 To UBound(data)
        Set wsDest = Nothing
        shn = data(i, 1)
        On Error Resume Next
        Set wsDest = Sheets(shn)
        On Error GoTo 0
        If wsDest Is Nothing Then
            Set wsDest = Sheets.Add(After:=Sheets(Worksheets.Count))
            wsDest.Name = shn
           wsDest.Cells(1, 1).Value = data(i, 2)
        Else
            wsDest.UsedRange.Offset(1).ClearContents
        End If
    Next i
    
End Sub

マナ

[nero6014]

You asked me to show my expected result, so in the workbook I manually copied the header row and the matching rows to the worksheets, that's what I want to do with vba.

[mana]

Sorry, I still don't understand.
There is only one worksheet in your book.

[nero6014]

Ok, I don't know what else to do so I give up, thanks for your time.

[Logit]

.
Here is one way to accomplish your goal :

Option Explicit


Sub CreateSheets()
    Dim dicKey, dicValues, data, lastrow As Long
    Dim i As Long, ws As Worksheet, wsDest As Worksheet
    Set ws = ActiveSheet
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    data = Range("A2:A" & lastrow) ' load data into variable
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(data)
            If .Exists(data(i, 1)) = False Then
                dicKey = data(i, 1) 'set the key
                dicValues = data(i, 1) 'set the value for data to be stored
                .Add dicKey, dicValues
                Set wsDest = Sheets.Add(After:=Sheets(Worksheets.Count))
                wsDest.Name = data(i, 1)
               ' Sheets(data(i, 1)).Cells(1, 1).Value = ws.Cells(i + 1, 1).Value
               ' Sheets(data(i, 1)).Cells(1, 2).Value = ws.Cells(i + 1, 2).Value
            End If
        Next i
    End With
End Sub




Sub copypaste()
    Dim dicKey, dicValues, data, lastrow As Long
    Dim i As Long, ws As Worksheet, wsDest As Worksheet
    Set ws = ActiveSheet
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    data = Range("A2:A" & lastrow) ' load data into variable
    
 With CreateObject("scripting.dictionary")
        For i = 1 To UBound(data)
            If .Exists(data(i, 1)) = False Then
                dicKey = data(i, 1) 'set the key
                dicValues = data(i, 1) 'set the value for data to be stored
                .Add dicKey, dicValues
                
                Sheets(data(i, 1)).Cells(1, 1).Value = ws.Cells(i + 1, 1).Value
                Sheets(data(i, 1)).Cells(1, 2).Value = ws.Cells(i + 1, 2).Value
            End If
        Next i
    End With
End Sub

[nero6014]

Thank You for your assistance

[Logit]

.
You are welcome.