Macro for copy and pasting duplicates

dgreens5,

Welcome to the Excel Forum.


With your raw data in worksheet Sheet1, already sorted/grouped per your sample workbook:


Detach/open workbook ReorgData - w1 to resultNBRs - dgreens5 - EF860341 - SDG10.xlsm and run the ReorgData macro.



If you want to use the macro on another workbook:


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' stanleydgromjr, 09/13/2012
' http://www.excelforum.com/excel-general/860341-macro-for-copy-and-pasting-duplicates.html
Dim w1 As Worksheet, ws As Worksheet
Dim lr As Long, r As Long, n As Long, rs As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
rs = 0
For r = 1 To lr
  n = Application.CountIf(w1.Columns(1), w1.Cells(r, 1).Value)
  rs = rs + 1
  If Not Evaluate("ISREF(result" & rs & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "result" & rs
  Set ws = Worksheets("result" & rs)
  ws.Cells(1, 1).Resize(n, 2).Value = w1.Cells(r, 1).Resize(n, 2).Value
  r = r + n - 1
Next r
w1.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgData macro.

hi stan! the macro was so cool thank you for this! this is such a big help! is it possible to have the name of each worksheet created is the unique name in the first column? like it would be named automatically considering each unique word in the first column? and will automatically be auto formatted as a simple format?

dgreens5,

Try:


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub ReorgDataV2()
' stanleydgromjr, 09/14/2012
' http://www.excelforum.com/excel-general/860341-macro-for-copy-and-pasting-duplicates.html
Dim w1 As Worksheet, ws As Worksheet
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(w1.Columns(1), w1.Cells(r, 1).Value)
  If Not Evaluate("ISREF(" & w1.Cells(r, 1).Value & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = w1.Cells(r, 1).Value
  Set ws = Worksheets(w1.Cells(r, 1).Value)
  w1.Cells(r, 1).Resize(n, 2).Copy ws.Cells(1, 1).Resize(n, 2)
  ws.UsedRange.Columns.AutoFit
  r = r + n - 1
Next r
w1.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgDataV2 macro.

Unfair, how could that be so easy for you!? thanks a bunch Stan! such a big help indeed.

btw stan, what code to add if ill automatically format each of them as a simple format?.. the "alt + o + simple format" thing?

bigdan,

Thanks for the feedback.

You are very welcome. Glad I could help.

btw stan, what code to add if ill automatically format each of them as a simple format?.. the "alt + o + simple format" thing?

The formats for the new worksheets data should be the same as Sheet1 because I copied the data.

The workbook that you posted did not seem to have any different/special formatting?

bigdan,


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgDataV3()
' stanleydgromjr, 09/14/2012
' http://www.excelforum.com/excel-general/860341-macro-for-copy-and-pasting-duplicates.html
Dim w1 As Worksheet, ws As Worksheet
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(w1.Columns(2), w1.Cells(r, 2).Value)
  If Not Evaluate("ISREF(" & w1.Cells(r, 2).Value & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = w1.Cells(r, 2).Value
  Set ws = Worksheets(w1.Cells(r, 2).Value)
  With ws.Cells(1, 1).Resize(, 3)
    .Value = [{"Survey#","Question","Response"}]
    .HorizontalAlignment = xlCenter
    .Font.FontStyle = "Bold"
    .Font.Size = 11
    .Borders(xlEdgeTop).Weight = xlMedium
    .Borders(xlEdgeBottom).Weight = xlThin
  End With
  w1.Cells(r, 1).Resize(n, 3).Copy ws.Cells(2, 1).Resize(n, 3)
  ws.Cells(n + 1, 1).Resize(, 3).Borders(xlEdgeBottom).Weight = xlMedium
  ws.UsedRange.Columns.AutoFit
  r = r + n - 1
Next r
w1.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgDataV3 macro.

and you sir did it again! Stan, this is the shizzz! my dilemma is over. Thank you for sharing your idea, Stan! Hope you'll still help me in the near future. Ill be looking for you! :D bunch of thanks and respect.

dgreens5,

Thanks for the feedback.

Your are very welcome. Glad I could help.

Come back anytime.