Cut rows to new sheet based on values in column - excel

I have this list of products, and i want to:
Create new sheets based on the values on column C, if there's already a sheet with the same name as the cell value don't create a new sheet. (like "Abstract" in my example that already been created for row 2 and doesn't need to created again for row 3)
Cut the entire row to the matching sheet.
Make sure the first row is copied to all sheets.
This is a before picture
After Pic #1: new sheets created, nothing left on first sheet except the 1st row
After Pic #2: the sheet contains 2 products because there were 2 "Abstract" in column C
After Pic #3: the sheet contain 1 product because there was 1 "Plain" in column C
After Pic #4: the sheet contain 1 product because there was 1 "Shiny" in column C

This will get the job done.
I Named the first sheet to "Worksheet".
The code is dynamic, so you need to input 2 values by yourself:
Which range/names that should create the new worksheets:
Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list
and how many columns you want to copy to the new sheets (it makes it more dynamic than take the whole row)
lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet
VBA Code:
Sub AddNewSheetFromRange2()
Dim c As Range
Dim ws As Worksheet
Dim myrange As Range
Dim lastcol As Integer
Dim lrow As Integer
Dim lrow_newsheet As Integer
Dim i As Integer
Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list
lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet
lrow = Cells(Rows.Count, 3).End(xlUp).Row 'find last row for range that should create the new worksheet list
i = 1 'Set first index loop to 1
For Each c In myrange.Cells
i = i + 1 'Create index for each loop, used to know which row that should be copied
'Debug.Print c 'Print which Sheet Name that will be examine
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(c.Value)
On Error GoTo 0
If ws Is Nothing Then
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Add new sheet after (not before)
ws.Name = c.Value 'Rename the new sheet
End With
Dim WorksheetSheet As Worksheet 'Declare variable for Main worksheet
Set WorksheetSheet = ActiveWorkbook.Worksheets("Worksheet") 'Name the Main sheet
Dim NewSheet As Worksheet 'Declare variable for new worksheet
Set NewSheet = ActiveWorkbook.Worksheets(ws.Name) 'Make all new worksheets dynamic by taking name from range
'Copy Headers from Main sheet to New Worksheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(1, 1), Cells(1, 3)).Copy
Worksheets(ws.Name).Activate
ThisWorkbook.Worksheets(ws.Name).Range(Cells(1, 1), Cells(1, 3)).PasteSpecial
'Copy row from Main sheet to New Worksheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
Worksheets(ws.Name).Activate
lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial
'Clear row in Main sheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear
Else
'If worksheet already exists, then
'Copy row from Main sheet to existing worksheet with exactly the same name
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
Worksheets(ws.Name).Activate
lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial
'Clear row in Main sheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear
End If
Next c
End Sub
Visualizing the code in excel you will have to start with this:
and the final output will be this (the four rows into individual worksheets, if the name already exists, it will add to the already existing worksheet)

Related

Use VBA to copy entire row from one excel worksheet to another if match is not found in Column A

I have been running into some issues trying to use VBA to compare 2 tables in different worksheets, and then copy any rows in the "Master" sheet that are not found in the "New" sheet. Both tables are formatted as tables. The match is based on an "ID" column in Column A of both tables. If an ID is in the "Master" sheet, but not in the "New" sheet, than that entire row should be copy and pasted to the end of the table in the "New" sheet.
I updated some code found in another forum, which is almost working. However, it only seems to paste over the ID data into Column A, and not the entire corresponding row of data which is needed.
Sub compare()
Dim i As Long
Dim lrs As Long
Dim lrd As Long
With Worksheets("Master")
lrs = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lrs 'assumes header in row 1
If Application.IfError(Application.Match(.Cells(i, 1), Worksheets("New").Columns(1), 0), 0) = 0 Then
lrd = Worksheets("New").Cells(Worksheets("test").Rows.Count, 1).End(xlUp).Row
Worksheets("New").Cells(lrd + 1, 1).Value = .Cells(i, 1).Value
End If
Next i
End With
End Sub
I think the issue has to do with the "Cells" reference, instead of a range, but I do not know how to make that line dynamic.
Slightly different approach, but you need to use something like Resize() to capture the whole row, and not just the cell in Col A.
Sub compare()
Const NUM_COLS As Long = 10 'for example
Dim wb As Workbook, wsSrc As Worksheet, wsDest As Worksheet
Dim c As Range, cDest As Range
Set wb = ThisWorkbook 'or ActiveWorkbook for example
Set wsSrc = wb.Worksheets("Master")
Set wsDest = wb.Worksheets("New")
Set cDest = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'next empty row
For Each c In wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row).Cells
If IsError(Application.Match(c.Value, wsDest.Columns(1), 0)) Then
cDest.Resize(1, NUM_COLS).Value = c.Resize(1, NUM_COLS).Value
Set cDest = cDest.Offset(1) 'next row
End If
Next c
End Sub

How to copy specific ranges into a new worksheet in VBA?

I'm trying to create a macro that will compile specific columns from all worksheets in a workbook into a single new worksheet.
What I have so far creates the new sheet, and returns the correct headers for each column, but copies across all columns from the existing sheets rather than just the columns I have specified.
As can be seen with the column headings, I would like to only copy the values in columns A:I, K:M, R and W:Y from sheets 2 onwards, into columns B:O in the "MASTER" worksheet.
Does anyone have any suggestions as to how I can get this working?
Sub Combine2()
Dim J As Integer, wsNew As Worksheet
Dim rngCopy As Range, rngPaste As Range
Dim Location As String
On Error Resume Next
Set wsNew = Sheets("MASTER")
On Error GoTo 0
'if sheet does not already exist, create it
If wsNew Is Nothing Then
Set wsNew = Worksheets.Add(Before:=Sheets(1)) ' add a sheet in first place
wsNew.Name = "MASTER"
End If
'copy headings and paste to new sheet starting in B1
With Sheets(2)
.Range("A1:I1").Copy wsNew.Range("B1")
.Range("R1").Copy wsNew.Range("K1")
.Range("K1:M1").Copy wsNew.Range("L1")
.Range("W1:Y1").Copy wsNew.Range("O1")
End With
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
'save sheet name/location to string
Location = Sheets(J).Name
'set range to be copied
With Sheets(J).Range("A1").CurrentRegion
Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
'set range to paste to, beginning with column B
Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
'copy range and paste to column *B* of combined sheet
rngCopy.Copy rngPaste
'enter the location name in column A for all copied entries
Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
Next J
With Sheets(1)
Range("A1").Value = "Extract Date"
Range("A1").Font.Bold = True
Columns("A:T").AutoFit
End With
' wsNew.Visible = xlSheetHidden
End Sub
Copy/paste each range in turn in the same way as you have for the headings. (untested)
Dim ar(4), k as Integer
ar(1) = array("A1:I1","B")
ar(2) = array("R1","K")
ar(3) = array("K1:M1","L")
ar(4) = array("W1:Y1","O")
'copy headings and paste to new sheet
With Sheets(2)
For k = 1 to Ubound(ar)
.Range(ar(k)(0)).Copy wsNew.Range(ar(k)(1) & "1")
Next
End With
' work through sheets
Dim lr As Long
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
'save sheet name/location to string
Location = Sheets(J).Name
'set range to be copied
With Sheets(J)
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For k = 1 to Ubound(ar)
Set rngCopy = .Range(ar(k)(0)).Offset(1).Resize(lr-1)
'set range to paste to, beginning with column B
Set rngPaste = wsNew.Cells(Rows.Count, ar(k)(1)).End(xlUp).Offset(1, 0)
'copy range and paste to combined sheet
rngCopy.Copy rngPaste
If k = 1 Then
'enter the location name in column A for all copied entries
Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
End If
Next
End With
Next J
Note this block is missing a dot on the ranges to use the With
With Sheets(1)
Range("A1").Value = "Extract Date"
Range("A1").Font.Bold = True
Columns("A:T").AutoFit
End With

VBA Copy Pivot Data to next blank cell in column

A pivot table has been created and I need a macro that can pick up the Pivot body data, with no filters, from a specified worksheet (Pivot1) and copy the results into another sheet (Selection) on the next blank cell.
I've used and modified the below, which I found on this site, however its not picking up my sheets and I get a runtime error '424'
Any ideas on how this can be executed?
Sub PastePivot()
Dim i As Long
Dim LR As Long
Dim j As Long
Dim c As Long
'Find last used row in Pivot1
LR = Pivot1.Cells(Pivot1.Rows.Count, 1).End(xlUp).Row
'Find last used row in Selection
j = Selection.Cells(Selection.Rows.Count, 1).End(xlUp).Row
'Loop through rows on Pivot1
For i = 3 To LR
'Decide whether to copy the row or not
If Pivot1.Cells(i, 1).Value <> "0" Then
'Update pointer to the next unused row in Selection
j = j + 1
'Only copy used columns, to stop it thinking every cell in the
'destination row is "used"
c = Pivot1.Cells(i, Pivot1.Columns.Count).End(xlToLeft).Column
'Copy the values (without using Copy/Paste via the clipboard)
Selection.Rows(j).Resize(1, c).Value = Pivot1.Rows(i).Resize(1, c).Value
End If
Next i
End Sub
If you want to get the body of a pivot table use it's DataBodyRange property.
The below code assumes you have 1 pivot table on 'Sheet1' and you want to copy it to 'Sheet2'.
Sub CopyPivotBody()
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngBody As Range
Set ws = Sheets("Sheet1")
Set pt = ws.PivotTables(1)
Set rngBody = pt.DataBodyRange
rngBody.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End Sub
Note, if that doesn't give you the exact range you want you can offset/resize it like any other range.

Adding a column stating the worksheet source of the data

The program's main function is to copy all the data in the worksheets opened and put it in a worksheet named "consolidated." Everything's working well, however, I want to add a column called "Data Source" wherein it can state where the data came from (e.g. Sheet1, Sheet2). But the thing is, it outputs the wrong sheet name.
I have tried different codes and I have attached what currently works below. I will highlight the part where I assume the problem comes from. I would really appreciate some help as I'm not a coder myself (just learned this a week ago).
For Each wksSrc In ThisWorkbook.Worksheets
'Skip Destination worksheet
If wksSrc.Name <> wksDst.Name And wksSrc.Name <> "Tool" Then
With wksSrc
'Identify the last row and column on this sheet
'so we know when to stop looping through the data
lngLastSrcRowNum = LastOccupiedRowNum(wksSrc)
lngLastSrcColNum = LastOccupiedColNum(wksSrc)
'Identify the last row of the Destination sheet
'so we know where to (eventually) paste the data
lngLastDstRowNum = LastOccupiedRowNum(wksDst)
'Loop through the headers on this sheet, looking up
'the appropriate Destination column from the Final
'Headers dictionary and creating ranges on the fly
For lngIdx = 1 To lngLastSrcColNum
strColHeader = Trim(CStr(.Cells(1, lngIdx)))
'Set the Destination target range using the
'looked up value from the Final Headers dictionary
Set rngDst = wksDst.Cells(lngLastDstRowNum + 1, _
dicFinalHeaders(strColHeader))
'Set the source target range using the current
'column number and the last-occupied row
Set rngSrc = .Range(.Cells(2, lngIdx), _
.Cells(lngLastSrcRowNum, lngIdx))
'Copy the data from this sheet to the destination
rngSrc.Copy Destination:=rngDst
Next lngIdx
Dim TargetColumn As Long
Dim FinalRow As Long
Dim rngAddress As Range
Dim i As Long
With wksDst
FinalRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngAddress = .Range("A:Z").Find("Data Source")
If Not rngAddress Is Nothing Then
TargetColumn = rngAddress.Column
''''THIS IS THE PART WHERE I ASSUME THE PROBLEM COMES FROM'''''
For i = 1 To FinalRow
.Cells(i, TargetColumn).Value = wksSrc.Name
Next i
End If
End With
End With
End If
Next wksSrc
End Sub
I already added the "Data Source" column but the wksSrc.Name part in the code always outputs only the last worksheet name when it should be different/dynamic depending on the worksheets where I got the data from.
This might help. When I make the i value to 1, it outputs the correct sheet name, however, it replaces the column header with the sheet name and the loop is only done once. When I make the i value to 2, it outputs the wrong sheet name but it starts to output in the correct first blank row of the Data Source column.
As mentioned in the comments. You are looping through the ENTIRE source name column each time. As such, at the end of your process you will be left with the last worksheet looped through. So in order to overcome this you need a StartRow as well as a FinalRow to only loop through data from that sheet. See below code (not tested) but I think you will get the idea of how to implement and it may work off the bat.
For Each wksSrc In ThisWorkbook.Worksheets
'Skip Destination worksheet
If wksSrc.Name <> wksDst.Name And wksSrc.Name <> "Tool" Then
With wksSrc
'Identify the last row and column on this sheet
'so we know when to stop looping through the data
lngLastSrcRowNum = LastOccupiedRowNum(wksSrc)
lngLastSrcColNum = LastOccupiedColNum(wksSrc)
'Identify the last row of the Destination sheet
'so we know where to (eventually) paste the data
lngLastDstRowNum = LastOccupiedRowNum(wksDst)
'Loop through the headers on this sheet, looking up
'the appropriate Destination column from the Final
'Headers dictionary and creating ranges on the fly
For lngIdx = 1 To lngLastSrcColNum
strColHeader = Trim(CStr(.Cells(1, lngIdx)))
'Set the Destination target range using the
'looked up value from the Final Headers dictionary
Set rngDst = wksDst.Cells(lngLastDstRowNum + 1, _
dicFinalHeaders(strColHeader))
'Set the source target range using the current
'column number and the last-occupied row
Set rngSrc = .Range(.Cells(2, lngIdx), _
.Cells(lngLastSrcRowNum, lngIdx))
'Copy the data from this sheet to the destination
rngSrc.Copy Destination:=rngDst
Next lngIdx
Dim TargetColumn As Long
Dim FinalRow As Long, StartRow As Long
Dim rngAddress As Range
Dim i As Long
With wksDst
Set rngAddress = .Range("A:Z").Find("Data Source")
If Not rngAddress Is Nothing Then
TargetColumn = rngAddress.Column
'set the start for this sheet
StartRow = lngLastDstRowNum + 1
'set the final row for this worksheet
FinalRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(StartRow, TargetColumn), .Cells(FinalRow, TargetColumn)).Value = wksSrc.Name
End If
End With
End With
End If
Next wksSrc
As can be seen your range adjustment on the wksDst should take into account the sheets data.

Copy data into different named multiple sheets

Dears,
I am a beginner and tried to prepare the macro that enables firstly delete rows based on condition, than create new sheets based on criteria from the first main sheet and add data from the first main sheet into multiple named sheets.
deletes rows based on condition (RUNs OK)
creates new sheets based on criteria from the first main sheet (RUNs OK)
adds data from the first main sheet (constant range I4:I6)
into multiple named sheets to A1:A3 in all of them (being created by this macro). Unfortunately I do not know how to do that :-(
Could you possibly help me, please?
Private Sub CommandButton1_Click()
Dim lastrow As Long, x As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = lastrow To 1 Step -1
If UCase(Cells(x, 3).Value) = "0" And _
UCase(Cells(x, 6).Value) = "0" Then
Rows(x).Delete
End If
Next
lastcell = ThisWorkbook.Worksheets("Obratova predvaha").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastcell
With ThisWorkbook
newname = ThisWorkbook.Worksheets("Obratova predvaha").Cells(i, 1).Value
.Sheets.Add after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = newname
End With
Next
ThisWorkbook.Worksheets("Obratova predvaha").Activate
ThisWorkbook.Worksheets("Obratova predvaha").Cells(1, 1).Select
End Sub
not very sure about your description, but you may try this:
edited to add a sheet variable and prevent any (possible?) time lapse misbehavior between new sheet adding and writing to it by implicitly assuming it as ActiveSheet:
Option Explicit
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
Dim newSheet As Worksheet
With Worksheets("Obratova predvaha")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If UCase(.Cells(i, 3).Value) = "0" And UCase(.Cells(i, 6).Value) = "0" Then .Rows(i).Delete
Next
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count)) ' add a new sheet and hold its reference in newSheet variable
newSheet.Range("A1:A3").Value = .Range("I4:I6").Value ' copy referenced sheet I4:I6 values into newly added sheet cells A1:A3
newSheet.Name = .Cells(i, 1).Value ' change the name of newly added sheet
Next
End With
End Sub

Resources