I have this vba code that appends/distributes records from a Data mastersheet to individual named sheets. This is done based on column E's value. It works fine but ends in an error whenever it encounters a value on column E that's not one of the sheets in the file. Can you please help me so as to allow it to just skip those records and proceed with the processing? Thanks!
Sub CopyDataToSheets()
Dim copyfromws As Worksheet
Dim copytows As Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long
Dim ctlr As Long
Dim i As Long
Dim currval As String
Set copyfromws = Sheets("Data")
cflr = copyfromws.Cells(Rows.Count, "B").End(xlUp).Row
' Copy Row of Data to Specific Worksheet based on value in Column E
' Existing Formulas in Columns F through H or J are automatically extended to the new row of data
For i = 2 To cflr
currval = copyfromws.Cells(i, 1).Value
Set copytows = Sheets(currval)
ctlr = copytows.Cells(Rows.Count, "B").End(xlUp).Row + 1
Set cfrng = copyfromws.Range("A" & i & ":N" & i)
Set ctrng = copytows.Range("A" & ctlr & ":N" & ctlr)
ctrng.Value = cfrng.Value
Next
End Sub
I would make a small helper function that can test if the worksheet exists. That way you can control the logic of your loop.
Function SheetExists(sheetName As String, Optional wb As Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(sheetName)
SheetExists = Err = 0
End Function
Related
Im trying to copy and paste my data and assign them into different worksheets.For example, if column F is martin 1, the entire row that has martin1 will be paste to worksheets("Index1"). Same thing for Charlie 1 and it will be paste to worksheets("Index2"). However, I faced with a object defined error here as shown in my code below. Any ideas how to solve it?
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Dim i As Integer
Dim site_i As Worksheet
For i = 1 To 3
Set site_i = Sheets.Add(after:=Sheets(Worksheets.count))
site_i.Name = "Index" & CStr(i)
Next i
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value = "Martin1" Then
ws.Range(sCel, ws.Cells(rwNbr, 6)).EntireRow.Copy Destination:=Sheets("Index1").Range("A1")
ElseIf ws.Cells(rwNbr, 6).Value = "Charlie1" Then
ws.Range(sCel, ws.Cells(rwNbr - ws.UsedRange.Rows.count, 6)).EntireRow.CopyDestination:=Sheets("Index2").Range("A1") '<----application defined or object defined error here
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
This is the link to my worksheet. https://www.dropbox.com/home?preview=Sample+-+Copy.xlsm
The final output should look something like this...
If your raw data does not have a header row then I would use a loop to gather up your target cells and copy them accordingly.
You will need to update your 3 target values inside Arr to Charlie1, Martin1, etc.
Macro Steps
Loop through each name in Arr
Loop through each row in Sheet1
Add target row to a Union (collection of cells)
Copy the Union to the target sheet where target Sheet Index # = Arr position + 1
Sub Filt()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim Arr: Arr = Array("Value1", "Value2", "Value3")
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Create 3 Sheets, move them to the end, rename
For x = 1 To 3
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
cs.Name = "Index" & x
Next x
lr = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
'Loop through each name in array
For Target = LBound(Arr) To UBound(Arr)
'Loop through each row
For i = 1 To lr
'Create Union of target rows
If ws.Range("F" & i) = Arr(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("F" & i))
Else
Set CopyMe = ws.Range("F" & i)
End If
End If
Next i
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Index" & Target + 1).Range("A1")
Set CopyMe = Nothing
End If
Next Target
End Sub
Tested and working as expected on my end, however....
If you had headers this would be much easier with a copy/paste. If you run the same macro on same book twice this will break for many reasons such as having duplicated sheet names, breaking the relationship between Sheet Index # = Arr Position + 1, etc...
I need help and I'm hoping someone here can help me :)
I have a workbook that runs some reports from Avaya CMS. It runs the report and creates a new sheet for each persons name on the MAIN sheet. << This part works wonderfully.
My issue is I cannot figure out how to use that range of names on the MAIN sheet to select only those specific sheets and then copy them to a new workbook.. There's 2 other hidden sheets as well.. Which is why I think using the range of names is easier but I'm open to anything at this point.
Here's an screeshot of what it looks like :
Sorry, I couldn't figure out how to upload the workbook here but the image should, hopefully, be good enough. Thank you for your time and help!
Here's an image with the hidden sheets.
I need it to exclude the first 3 sheets/
And here's the code:
Sub Macro1()
Dim sheetArray() As String
Dim i As Integer
i = 0
For Each c In MainSheet.Range("A2:A20").Cells
ReDim Preserve sheetArray(0 To i)
sheetArray(i) = c.Value
i = i + 1
Next
Sheets(sheetArray).Select
End Sub
Sub move_Sheets()
Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")
Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)
For a = 2 To i
shArray(a - 2) = mSH.Range("A" & a).Value
Next a
ThisWorkbook.Sheets(shArray).Move
End Sub
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, sheetIndex As Long
Dim SheetName As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Main")
'Last row of column where the names appears
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop the column from row 2 to last row
For i = 2 To LastRow
'Set Sheet name
SheetName = .Range("A" & i).Value
'Check if the sheet with the SheetName exists
If DoesSheetExists(SheetName) Then
'Insert the code to code
sheetIndex = Workbooks("Book2").Sheets.Count
ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
Else
End If
Next i
End With
End Sub
Function DoesSheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
My code is working when I just use a single workbook and communicate between sheets but gives me subscript out of range errors and object not defined errors when I attempt to reference a cell range in a sheet contained in a different work book. Right now, the error is occurring at "Set pidat = Worksheets("pidat")
Dim pival As Double
'Dim eom As Worksheet 'declaring pidat worksheet as variable
'Set eom = Worksheets("EOM") 'declaring eom worksheet as variable
'Set Inv_Level = Worksheets("Inv_Levels")
Dim pidat As Worksheet 'declaring eom worksheet as variable
Set pidat = Worksheets("pidat")
Dim steve As Workbook
Set steve = Application.Workbooks("EOM Report VBA")
Dim EOMAs As Workbook
Set EOMAs = Application.Workbooks("EOMA")
Dim Inv_Level As Worksheet
'These changes allow for a dynamic range to be referenced outside of the active sheet/workbook
Dim location As String
Dim rownum As Long
Dim loopy As Long
Dim fRng As Range
Dim J As Long
Dim rn As Date
Dim last As Date
Dim rnm As Integer
Dim lastm As Integer
Dim tyear As Long
Dim K As Long
With pidat
J = .Range("J2").Value
rn = Now
last = .Range("B1").Value
rnm = month(rn)
lastm = month(last)
tyear = year(rn)
If lastm < rnm Then
.Range("B1") = (rnm & "/" & "01" & "/" & tyear & " 07:30")
J = J + 100
.Range("J2") = J
End If
End With
K = J + 100
'names of workbook/sheet referenced
With steve
rownum = .Range("E" & Rows.Count).End(xlUp).Row 'counts the number of rows in the location tag column
For loopy = 3 To rownum 'Data values start after row 3, loops through each row in the column
If .Range("E" & loopy) <> "" Then
location = .Range("E" & loopy)
'newloc = location
With Inv_Level
Set fRng = .Cells.Range("A" & J, "ZZ" & K).Find(What:=location, LookIn:=xlFormulas, LookAt:=xlPart) 'eom can be any sheet you need to perform the .Find again
End With
If Not fRng Is Nothing Then
fRng.Offset(0, -1) = pidat.Range("D" & loopy)
Else: End If
'if the search item is not found, do nothing, go to next loop
End If
Next loopy
End With
End Sub
You need to qualify the specific workbook you want to work with.
The line Set pidat = Worksheets("pidat") will fail if the active workbook at the time this line is executed has no worksheet named pidat.
Here is an example of how to qualify a workbook
Dim theWorkbook as Workbook
Set theWorkbook = Application.Workbooks("myWorkbook")
Dim pidat as Worksheet
Set pidat = theWorkbook.Worksheets("pidat")
You could go one step further and verify that a sheet named pidat (or whatever) exists in the qualified workbook, but I'll leave you to discover how to do that :)
I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub
I'm trying to copy rows from master table sheet to different sheets based on the value of the cell in the column:
The column "AL" contains several values (validation list) for example dog, cat, giraffe, I'd like to automatically open new sheet for every value and copy the relevant rows to the new sheet. (the new sheets must have the name of the value).
In addition when a new data is added, I need the new rows to be added to the correct sheet.
Sub Copy_Data()
Dim r As Range, LastRow As Long, ws As Worksheet
Dim v As Variant, s As String, LastRow1 As Long
Dim src As Worksheet
Set src = Sheets("Sheet1")
LastRow = src.Cells(Cells.Rows.Count, "AL").End(xlUp).Row
'Change these to your strings to copy
s = "dog,cat,fish,giraffe"
v = Split(s, ",")
For Each r In src.Range("AL1:AL" & LastRow)
If Not IsError(Application.Match(CStr(r.Value), v, 0)) Then
On Error Resume Next
Set ws = Sheets(CStr(r.Value))
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "AL").End(xlUp).Row
src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
Set ws = Nothing
Else
LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "Al").End(xlUp).Row
src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
Set ws = Nothing
End If
End If
Next r
End Sub