I am not an expert on excel vba, but need to assistance with it.
I have an excel worksheet currently with two sheets
"Datas" sheet : All my long list of data (click to see) is here.
"Template" sheet. A template (click to see) i created to format my data
I know this is going to be bulky.
I need a macro, or button that
can create a new sheet based on the template above for each line in the Column A value in "Datas" sheet
the name of the new sheet will be taken from the Column A value in "Datas" sheet
The new sheet should retain the formatting of the template after data has been copied
In summary it should look somewhat like this
this (click to see) for the first line in column A of Datas sheet
and this (click to see) for the second line in column A of Datas Sheet.
Here is a sample of the worksheet uploaded on
https://ufile.io/bxwo6
I have infact tried the following
http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-sheets
PART 2 - Parse New Data To New Sheets (macro)
It did the job of taking each line and split it into different sheets. The results are
This is my Data sheet
This is the result of the split which is good
I am somehow stuck on how to make it adapt to my template formatting.
I would be grateful if you could provide any tip, help or suggestion that i can try
Many Thanks
UPDATE:
I have tried the following code. create a copy of the template and rename it according to the value in Column A from the source
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Datas").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("TEMPLATE").Copy After:=Sheets(Sheets.Count) 'Create a new worksheet as a copy of Sheet number 9 in this example
Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets
Next MyCell
End Sub
UPDATE 2: This is the code that i modified from the link above. Note we cannot rename the sheets using column ":" value therefore, i modified my source by changing it from 1:1 into 1, 1:2 into 2
Option Explicit
Sub ParseItems()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1
'Sheet with data in it
Set ws = Sheets("Data")
'option to append new data below old data
If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & _
"(if no, new data will replace old data)", _
vbYesNo, "Append new Data?") = vbYes Then Append = True
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:Z1"
TitleRow = Range(vTitles).Cells(1).Row
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from vCol
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"
For Itm = TitleRow + 1 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
'clear temporary list
ws.Columns(iCol).Clear
'Turn on the autofilter
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
NR = 1
Else 'if it exists already
Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count) 'ordering the sheets
If Append Then 'find next empty row
NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
Else
Sheets(CStr(MyArr(Itm))).Cells.Clear 'clear data if not appending
NR = 1
End If
End If
If NR = 1 Then 'copy titles and data
ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
Else 'copy data only
ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
End If
ws.Range(vTitles).AutoFilter Field:=vCol 'reset the autofilter
If Append And NR > 1 Then NR = NR - 1
MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count).End(xlUp).Row - NR
Sheets(CStr(MyArr(Itm))).Columns.AutoFit
Next Itm
'Cleanup
ws.Activate
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
& MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub
This should give you an idea which you can start with. It loops through the datas and for each data row it copies the template, renames it and fills in the data row into specific ranges.
Option Explicit
Public Sub AutoParseItems()
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Datas")
Dim lRow As Long
lRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row 'find last row in column A
Const fRow As Long = 1 'set first data row
Dim iRow As Long
For iRow = fRow To lRow 'loop throug data rows
'create a copy of the sheet
ThisWorkbook.Worksheets("TEMPLATE").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Dim wsNewTemplateCopy As Worksheet
Set wsNewTemplateCopy = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'determine new sheet name and rename the sheet
With wsData.Cells(iRow, "A")
wsNewTemplateCopy.Name = Right$(.Text, Len(.Text) - InStr(1, .Text, ":")) 'find : to determine new sheet name
End With
'fill in the text into the new sheet
wsNewTemplateCopy.Range("A1").Value = wsData.Cells(iRow, "A").Value
wsNewTemplateCopy.Range("A5").Value = wsData.Cells(iRow, "C").Value
wsNewTemplateCopy.Range("A22").Value = wsData.Cells(iRow, "D").Value
'modify the ranges where you need your data
Next iRow
End Sub
Related
I have a sheet named "RAW ITEMS" with data, and also have few more sheets with different name, where i need to move data from "RAW ITEMS" sheet. and all sheet name are available at sheet "RAW ITEMS" in Column C3 to C100.
When I run below code It's works good when I run it first time.
But when I add some data to Sheet "RAW ITEMS", It's also move earlier Rows to their related sheet. I can't figure out how to stop moving duplicate rows.
I mean how to skip if duplicate raw found in those sheets where data are moving?
Sub copyPasteData()
Dim PV As String
Dim ps As String
Dim LastRow As Long
PV = "RAW ITEMS"
Sheets(PV).Visible = True
Sheets(PV).Select
Range("C3").Select
Do While ActiveCell.Value <> ""
ps = ActiveCell.Value
ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
Selection.Copy
Sheets(ps).Visible = True
Sheets(ps).Select
LastRow = pvs("A")
Cells(LastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets(PV).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.Offset(1, 0).Select
Loop
Range("A1").Select
End Sub
Public Function pvs(col)
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
pvs = LastRow
End Function
I am newbies in VBA. Please help me.
how to skip if duplicate raw found in those sheets where data are moving?
This is the file link for better understand
Try the next code, please. It avoids any selection, activation which consumes Excel resources, without bringing any benefit. It should be fast, using arrays and working in memory:
Sub copyPasteData()
Dim PVWs As Worksheet, PSWs As Worksheet, arrPV, arrPS, arPV, arPS
Dim LastRPv As Long, LastRPs As Long, lastCol As Long, i As Long
Dim j As Long, boolCopy As Boolean
Set PVWs = Worksheets("RAW ITEMS")
LastRPv = PVWs.Range("C" & Rows.Count).End(xlUp).Row
lastCol = PVWs.UsedRange.Columns.Count
'load the range in an array:
arrPV = PVWs.Range(PVWs.Range("A" & 2), PVWs.Cells(LastRPv, lastCol)).Value
For i = 1 To UBound(arrPV) 'iterate between the array rows
On Error Resume Next
Set PSWs = Worksheets(CStr(arrPV(i, 3))) 'set the sheet to paste, if no a similar row exists
If Err.Number = 9 Then
Err.Clear: On Error GoTo 0
Dim ans As VbMsgBoxResult
ans = MsgBox("The sheet " & CStr(arrPV(i, 3)) & " does not exist!" & vbCrLf & _
"Would you like to create it?", vbYesNo, "Sheet creation confirmation")
If ans <> vbYes Then GoTo OverIt
Set PSWs = Worksheets.Add(after:=Worksheets(Worksheets.Count)) 'add the new sheet (after the last)
PSWs.Name = arrPV(i, 3) 'name the newly inserted sheet
'copy the header from the previous sheet:
PSWs.Previous.Range("A1:G1").Copy Destination:=PSWs.Range("A1")
End If
On Error GoTo 0
arPV = Application.Index(arrPV, i, 0) 'a slice of the i row (1D array)
LastRPs = PSWs.Range("A" & Rows.Count).End(xlUp).Row 'last row
'load the sheet existing range in an array
arrPS = PSWs.Range(PSWs.Range("A" & 1), PSWs.Cells(LastRPs, lastCol)).Value
For j = 1 To UBound(arrPS) ' iterate and check if the sliced rows are all the elements identic
boolCopy = True
arPS = Application.Index(arrPS, j, 0) 'a slice of the j row (1D array)
If Join(arPV, "|") = Join(arPS, "|") Then 'check if the rows are the same
boolCopy = False: Exit For
End If
Next j
If boolCopy Then
'if not alsready in the sheet, the array is copied
PSWs.Range("A" & LastRPs + 1).Resize(1, UBound(arPV)).Value = arPV
boolCopy = False 'reinitialize the Boolean variable
End If
OverIt:
Next i
End Sub
The code logic assumes that "duplicate row" means that all the cells values on a sheet to copy row are identic whit the one of the analyzed row to be copied.
And in the C column the sheet itself name should exist...
I'm writing a macro to sort through a large file of data at work. I've inserted a blank row at the top of different section of data. I want my code to realize when a row is blank in column C, then fill in a set of headers in that row. It should then continue to find the next blank in column C. This should continue until my code finds 2 consecutive blanks, which signals the end of my data.
Currently, my code inserts the desired headers, but only in the first row of my worksheet. I believe that I need to change the loop contained inside my "Do... Loop Until" function. I just can't seem to get the correct code to achieve my desired results.
I've included a screencapture of roughly what my spreadsheet will look like.
Any help or advice is greatly appreciated.
This is the code I have so far:
Sub AddHeaders()
'Add headers below each section title
Dim Headers() As Variant
Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long, Row As Long
Application.ScreenUpdating = False 'turn this off for the macro to run a
little faster
Set wb = ActiveWorkbook
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveCell = Cells(1, 3)
Headers() = Array("Item", "Configuration", "Drawing/Document Number",
"Title", "ECN", "Date", "Revisions")
' Set Do loop to stop when two consecutive empty cells are reached.
Do
For Row = 1 To LastRow 'Add a loop to go through the cells in each row?
If IsEmpty(ActiveCell) = True Then 'If row is empty, then go in and add headers
For i = LBound(Headers()) To UBound(Headers())
Cells(Row, 1 + i).Value = Headers(i)
Next i
Rows(Row).Font.Bold = True
'Loop here
End If
Next Row
ActiveCell = ActiveCell.Offset(1, 0)
Loop Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Application.ScreenUpdating = True 'turn it back on
MsgBox ("Done!")
Is this what you are looking for?
I removed the activecell stuff and used range instead.
Also removed the do loop and only use the for loop.
I think it works but Not sure. It does not look like you have on your picture but I keept your text code.
Sub AddHeaders()
'Add headers below each section title
Dim Headers() As Variant
Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long, Row As Long
Application.ScreenUpdating = False 'turn this off for the macro to run a
Set wb = ActiveWorkbook
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
ActiveCell = Cells(1, 3)
Headers() = Array("Item", "Configuration", "Drawing/Document Number", "Title", "ECN", "Date", "Revisions")
' Set Do loop to stop when two consecutive empty cells are reached.
For Row = 1 To LastRow 'Add a loop to go through the cells in each row?
If Range("C" & Row).Value = "" Then 'If row is empty, then go in and add headers
For i = LBound(Headers()) To UBound(Headers())
Cells(Row, 1 + i).Value = Headers(i)
Next i
Rows(Row).Font.Bold = True
'Loop here
End If
Next Row
Application.ScreenUpdating = True 'turn it back on
MsgBox ("Done!")
End Sub
Edit; Include image of output of above code.
Here's how I would do it:
Sub AddHeaders()
Dim nRow As Integer
nRow = 1
Do Until Range("C" & nRow) = "" And Range("C" & nRow + 1) = ""
If Range("C" & nRow) = "" Then
Range("A" & nRow & ":D" & nRow) = "Header"
End If
nRow = nRow + 1
Loop
End Sub
I am attempting to copy and paste Rows from an original sheet (Ticket Sales) to a new Sheet (Rachel) based on the value in a specific Column for each Row (Column U). I want all the sales from Rachel to be copied over to another sheet, pretty much. No change in the formatting for the second sheet. This is what I have so far:
Sub CopyRachelDataPaste()
Dim i, LastRow
'Get Last Row
LasRow = Sheets("Ticket Sales").Range("A" & Rows.Count).End(xlUp).Row
'Clear Contents
Sheets("Rachel").Range("A2:AB3000").ClearContents
For i = 2 To LastRow
If Sheets("Ticket Sales").Cells(i, "U").Value = "Rachel" Then
Sheets("Ticket Sales").Cells(i, "U").EntireRow.Copy Destination:=Sheets("Rachel").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub
you must properly reference worksheet in all range definitions
like follows:
Option Explicit
Sub CopyRachelDataPaste()
Dim i As Long, lastRow As Long
Worksheets("Rachel").Range("A2:AB3000").ClearContents 'Clear Contents
With Worksheets("Ticket Sales") '<--| reference ticket worksheet
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row '<--| get referenced worksheet column "A" last non empty row
For i = 2 To lastRow
If .Cells(i, "U").Value = "Rachel" Then .Cells(i, "U").EntireRow.Copy Destination:=Worksheets("Rachel").Range("A" & Worksheets("Rachel").Rows.Count).End(xlUp).Offset(1)
Next i
End With
End Sub
I have the following macro (part of it is copied). I want to move data from the Limas sheet to the Constanta sheet. The Constanta sheet already contains some information. By running the macro, this information disappears.
How do I change the code so that the information from the Limas sheet is copied to the Constanta sheet on the first blank row?
Sub Limas()
Dim LSheetMain, LSheet1, LSheet2, LSheet3, LSheet4 As String
Dim LSheet5, LSheet6 As String
Dim LContinue As Boolean
Dim LFirstRow, LRow As Integer
Dim LCurCORow, LCurRRow, LCurRERow, LCurPRow, LCurBRow As Integer
'Set up names of sheets
LSheetMain = "Limas"
LSheet1 = "Constanta"
LSheet2 = "Rastolita"
LSheet3 = "Reghin"
LSheet4 = "Poliesti"
LSheet5 = "Bucharest"
LSheet6 = "Curtiu"
'Initialize variables
LContinue = True
LFirstRow = 2
LRow = LFirstRow
LCurCORow = 2
LCurRRow = 2
LCurRERow = 2
LCurPRow = 2
LCurBRow = 2
LCurCuRow = 2
Sheets(LSheetMain).Select
'Loop through all column I values until a blank cell is found
While LContinue = True
'Found a blank cell, do not continue
If Len(Range("A" & CStr(LRow)).Value) = 0 Then
LContinue = False
'Copy and format data
Else
'--- "Constanta" ---
If Range("I" & CStr(LRow)).Value = "Constanta" Then
'Copy values from columns A, B, C, and H from "Limas" sheet
Range("A" & CStr(LRow) & ",B" & CStr(LRow) & ",C" & _
CStr(LRow) & ",H" & CStr(LRow)).Select
Selection.copy
'Paste onto "Constanta" sheet
Sheets(LSheet1).Select
Range("A" & CStr(LCurCORow)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
'Increment row counter on "Constanta" sheet
LCurCORow = LCurCORow + 1
'Go back to "Limas" sheet and continue where left off
Sheets(LSheetMain).Select
End If
Declaring variables in this manner means that only the last one on each line is declared as a string; all of the others are declared as variant types.
Dim LSheetMain, LSheet1, LSheet2, LSheet3, LSheet4 As String
Dim LSheet5, LSheet6 As String
Should be:
Dim LSheetMain As String, LSheet1 As String, LSheet2 As String, LSheet3 As String
Dim LSheet4 As String, LSheet5 As String, LSheet6 As String
As to your problem moving the data, rather than loop through the rows looking for Constanta (or one of the other worksheet names) in column I, filter on column I and copy the visible cells to the appropriate worksheet. Since we only got a portion of your code, I'll assume that you wanted to loop through each of the worksheets, copying from the Limas worksheet to the worksheet named the same as your filter.
Sub Limas()
Dim lr As Long, v As Long, vSheets As Variant
vSheets = Array("Limas", "Constanta", "Rastolita", "Reghin", "Poliesti", "Bucharest", "Curtiu")
With Sheets(vSheets(0)).Cells(1, 1).CurrentRegion
lr = .Rows.Count
For v = 1 To UBound(vSheets)
.AutoFilter
.AutoFilter Field:=9, Criteria1:="=" & vSheets(v), Operator:=xlAnd
If CBool(Application.Subtotal(103, .Columns(9).Offset(1, 0))) Then
.Range("A2:C" & lr & ",H2:H" & lr).Copy _
Destination:=Sheets(vSheets(v)).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
' remove commenting to activate deleting the rows after the copy
'.Offset(1, 0).EntireRow.Delete
End If
.AutoFilter
Next v
End With
End Sub
I've commented out the line that removed the rows from the Limas worksheet after copying. After you have tested this, you can uncomment that line. This code snippet assumes that all of those worksheets exist in the workbook.
I have created vba code to copy a row in the Sheet 1 to Sheet . The problem is that I need to be able to link the row copied, so that when Sheet 1 changes the copied row will be updated automatically. This would mean that I would need to somehow reference the row in Sheet 1 to Sheet 2. I have tried .Formula . Address, but these all copy either the value or the the cell reference into the Sheet 2. Here it the code that I have:
Here is the code:
Sub CopyCell()
Dim LastRow As Long
Dim i As Long, j As Long
Dim WListo As ListObject
Dim Lrow As Long
Dim lngLast As Long
'Find the last used row in Sheet1
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Sheet2").Range("Table4")
lngLast = .Cells(.Rows.Count, "A").End(xlUp).Row
If Worksheets("Sheet2").Range("A" & lngLast) <> "" Then
With Worksheets("Sheet2").ListObjects("Table4").ListRows.Add
End With
End If
With Worksheets("Advisory").Range("Table4")
nLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
End With
'This adds the last row
i = LastRow
With Worksheets("Sheet1")
If .Cells(i, 1).Value > "" Then
**///This is where I am having the problem
'Worksheets("Sheet2").Range("A1") = Rows(i).Address(True, True, True, True)
'Worksheets("Sheet2").Range("A" & nLastRow).Address = Worksheets("Sheet2").Range("A1")
'Worksheets("Sheet2").Range("A" & nLastRow) = Rows(i).FormulaR1C1
'Worksheets("Sheet2").Range("A" & nLastRow).Value = Rows(i).Value
'Worksheets("Sheet2").Range("A" & nLastRow) = Rows(i).FormulaR1C1
'Worksheets("Sheet2").Range("A" & nLastRow) = Rows(i).Address(, False, False, True)
**/This works if I just want to copy the rows but it is not linked
'Rows(i).Copy Destination:=Worksheets("Sheet2").Range("A" & nLastRow)
'nLastRow = nLastRow + 1
End If
End With
End Sub
You can try something like this:
Rows(i).Copy
Worksheets("Sheet2").Range("A" & nLastRow).Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
This will paste a link to the source row into the range on your target sheet.
I don't think there's a direct way to paste links using the Copy function arguments.