PDA

View Full Version : [SOLVED] Move matching rows to existing sheets



nero6014
09-15-2017, 12:55 PM
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
09-15-2017, 07:42 PM
Please post a sample book with small data and your expected results.

nero6014
09-16-2017, 04:51 PM
20372A1, 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
09-16-2017, 07:04 PM
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
09-17-2017, 04:29 AM
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
09-17-2017, 05:18 AM
Sorry, I still don't understand.
There is only one worksheet in your book.

nero6014
09-17-2017, 01:16 PM
Ok, I don't know what else to do so I give up, thanks for your time.

Logit
09-19-2017, 05:42 PM
.
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
09-20-2017, 12:36 PM
Thank You for your assistance

Logit
09-20-2017, 02:24 PM
.
You are welcome.