5630

create macro that will convert excel rows from single sheet to new sheets

Question:

I need to create macro that will convert excel rows from single sheet to new sheets.

I have 3 Rows of headers followed by lots of rows of data.

I would like to place each row on this sheet "Dept" into new sheets of their own (with the exception of the header rows). On each new sheet created, I would like the top 3 rows (the headers) repeated and formatting copied (if possible), then the single corresponding row from the "Dept" sheet. I would also like the new sheets to be named the value entered in column A (i.e. Ceiling Lights or Wall Lights from the example below).

I have no macro experience, so I'm having trouble taking code from previous answers and trying to apply it to my cause. Thanks for the help!

A B C D <ol><li>

dept template // promos // quicklinks // main banner

</li> <li>

where found // content slot // category // attributes

</li> <li>

blank // content asset // html // hero image

</li> <li>

Ceiling Lights // value // value // value

</li> <li>

Wall Lights // value // value // value

</li> <li>

Floor Lights // value // value // value

</li> </ol>

Converted to new sheets in the same workbook that have a single row after the 3 header rows:

new sheet named: Ceiling Lights

A B C D <ol><li>

dept template // promos // quicklinks // main banner

</li> <li>

where found // content slot // category // attributes

</li> <li>

blank // content asset // html // hero image

</li> <li>

Ceiling Lights // value // value // value

</li> </ol>

new sheet named: Wall Lights

A B C D <ol><li>

dept template // promos // quicklinks // main banner

</li> <li>

where found // content slot // category // attributes

</li> <li>

blank // content asset // html // hero image

</li> <li>

Wall Lights // value // value // value

</li> </ol>

Here's the code I have so far...

Sub Addsheets() Dim cell As Range Dim b As String Dim e As String Dim s As Integer Sheets("Dept").Select a = "a4" e = Range(a).End(xlDown).Address 'get's address of the last used cell 'loops through cells,creating new sheets and renaming them based on the cell value For Each cell In Range(a, e) s = Sheets.Count Sheets.Add After:=Sheets(s) Sheets(s + 1).Name = cell.Value Next cell Application.CutCopyMode = True Dim Counter As Long, i As Long Counter = Sheets.Count For i = 1 To Counter Sheets("Dept").Cells(1, 3).EntireRow.Copy Sheets(i).Cells(1, 3).PasteSpecial Next i Application.CutCopyMode = False End Sub

I can get the new sheets to create and name based on the cells in column A with the top portion of code, but when I tried adding code to have the first three rows (the header rows) copy to each of these newly created sheets I get Error 9 Subscript out of range for: Sheets(i).Cells(1, 3).PasteSpecial.

Not sure how to fix? Also, is there a way to preserve the header formatting (column widths)?

Answer1:

Is this what you are trying?

Option Explicit Sub Sample() Dim ws As Worksheet, tmpSht As Worksheet Dim LastRow As Long, i As Long, j As Long '~~> Change Sheet1 to the sheet which has all the data Set ws = Sheets("Sheet1") With ws LastRow = .Range("A" & .Rows.Count).End(xlUp).Row If LastRow < 4 Then Exit Sub For i = 4 To LastRow If DoesSheetExist(.Range("A" & i).Value) Then Set tmpSht = Sheets(.Range("A" & i).Value) Else Sheets.Add After:=Sheets(Sheets.Count) Set tmpSht = ActiveSheet tmpSht.Name = .Range("A" & i).Value End If .Rows("1:3").Copy tmpSht.Rows(1) For j = 1 To 4 tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth Next j .Rows(i).Copy tmpSht.Rows(4) Next End With End Sub Function DoesSheetExist(Sht As String) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = Sheets(ws) On Error GoTo 0 If Not ws Is Nothing Then DoesSheetExist = True End Function

Recommend

  • run Rmpi on cluster, specify library path
  • Trying to circular crop image with HTML and CSS
  • How to know what r is doing behind the scene
  • GitLab CI Runner, how to use volumes or mounts in service containers
  • Automatic email sending with timer control
  • Can I add columns in a QListView in Qt?
  • how check is the json Array available and exist?
  • UIPopoverController for iPhone
  • UpdateException when using SQL Server Compact with Entity Framework
  • SyntaxError: Unexpected token ' in JSON at position 1
  • Angular 2: Is there a way to bind a hashtag to a div?
  • Cassandra eats memory
  • Get process output without blocking
  • Need to display iframe when link is clicked from menu
  • Getting p-values from leave-one-out in R
  • Vim syntax highlighting
  • In Ember.js, what's the difference between store save and store commit?
  • How to load files to local file system with vibed?
  • Why can't pass only 1 coulmn to glmnet when it is possible in glm function in R?
  • Matlab Generating a Matrix
  • Laravel S3 File Upload MimeType Issue
  • Qt: closing modal dialog closes the program
  • c#.NET USB device persistent identifier
  • Nginx raises 404 when using format => 'js'
  • Error: java.util.Arrays$ArrayList cannot be cast to java.util.ArrayList
  • how to add semantic ui in a rails app?
  • Why can't I extract data from media file using AVURLAsset in a Playground?
  • Scrolling News Ticker Jquery - Issues
  • Using extern @class in order to add a category?
  • “A GKScore must specify a leaderboard.”
  • How to stamp out template in self contained custom elements with vanilla js?
  • xtable package: Skipping some rows in the output
  • C++ Partial template specialization - design simplification
  • KeystoneJS: Relationships in Admin UI not updating
  • Proper way to use connect-multiparty with express.js?
  • Load html files in TinyMce
  • JaxB to read class hierarchy
  • Observable and ngFor in Angular 2