I need to create new sheets based on unique names found in column A. Current Code generates excess data in certain sheets - vba

I have the following code so far based on questions asked by other people.
I have a set of names listed in column A, and 216 columns and 9725 rows of data.
Currently using the following code I get the new sheets created except along with the unique names and its relevant data I get many cells filled with "#N/A".
In certain cases, the name Bob for example will be populated in a new sheet called Bob but the first column will have Bob and all relevant data and once all Bobs rows are shown it is follower with many rows with #N/A and all columns with #N/A.
In other cases the sheet will be created for Charles and all of Charles data will be listed, then many rows of #N/A and then all of the master-data including other peoples names which I need to avoid.
I want each individual sheet to only have the info based on the name of the person on that sheet. All of the data gets copied as I verified the number of accurate cells that get populated yet I get these #N/A cells and duplicated extra data and I'm not sure how to stop it from being populated? Any help in cleaning the code would be appreciated!!
Code:
Sub CopyDataFromReportToIndividualSheets()
Dim ws As Worksheet
Set ws = Sheets("FormulaMSheet2")
Dim LastRow As Long
Dim MyRange As Range
Worksheets("FormulaMSheet2").Activate
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
' SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:BO" & LastRow).Sort Key1:=ws.Range("A1")
', Key2:=ws.Range("B1")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim allAgentNameCells As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set allAgentNameCells = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In allAgentNameCells
If cell.Value <> " " And cell.Value <> "" Then
' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove.
' Current Row's Series not SPACE
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
End If
Next
'' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, name As String)
Dim tgt As Worksheet
Dim MyRange As Range
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
Else
If Series = " " Then
End
End If
End If
Worksheets("FormulaMSheet2").Activate
' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
Worksheets("FormulaMSheet2").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.name = name
Set tgt = Sheets(name)
' copy data from src to tgt
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Variant
For Each ws In ThisWorkbook.Sheets
If ws.name = name Then
SheetExists = True
Exit Function
End If
Next
SheetExists = False
End Function

You need replace the
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
to
src.Range("A" & Start & ":BO" & Last).SpecialCells(xlCellTypeVisible).Copy Destination:=tgt.Range("A2:BO2" & Last - Start + 2)

I found what I needed at the following site: http://www.rondebruin.nl/win/s3/win006_5.htm .
I figured if anyone else was looking for similar code it would help taking a look at the site.

Related

Different sheet pasting

I have written a code which gives me the errors (if any cell is non numeric) in a separate sheet called "Error_sheet".
But the output is a bit clumsy as it gives me non numeric cell address in a confusing fashion. Like the errors will not be pasted one after another. There will be some blanks in between if there are more than one non Numeric cells.
Sub Test()
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If IsNumeric(Range("A" & i).Value) Then
Else
Sheets("Error").Range("A" & Row).Value = "Error in" & i & " row of ColumnNAme"
Row = Row + 1
End If
Next i
End Sub
It gives me output like shown below but can I get the output like Error in 7,14 rows of column name in a desired cell of "Error_sheet".
[![Output][1]][1]
[1]: https://i.stack.imgur.com/JqXwq.png
My understanding of what you've written is that you want something like this.
Option Explicit
Sub Test()
' Unqualified book/sheet below, means code will always run the isnumeric check on the cells of the active sheet. Is that what you want? '
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim Index as long
Dim i As Long
Dim NonNumericRows() as string
Redim NonNumericRows(1 to lastrow)
For i = 2 To LastRow
If not(IsNumeric(Range("A" & i).Value)) Then
Index = index + 1
NonNumericRows(Index) = cstr(i)
End if
Next i
Redim preserve NonNumericRows(1 to index)
Sheets("Error").Range("A1").Value = "Error in row(s): " & strings.join(nonnumericrows,", ") & " of ColumnNAme"
End Sub
Hope it works or helps.
Like QHarr suggested, using Option Explicit is normally a good idea, and try not to use VBA operators as variables.
Also when working with more than 1 sheet, its best to define each in the code. I dont know what your first sheet is called, so please change the line: Set shSource = Sheets("Sheet1") to suit:
Option Explicit
Sub SubErrorSheet()
Dim lr As Long, i As Long
Dim shSource As Worksheet, shError As Worksheet
Set shSource = Sheets("Sheet1")
Set shError = Sheets("Error")
lr = shSource.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lr
If Not IsNumeric(shSource.Range("A" & i).Value) Then
shError.Range("A" & Rows.count).End(xlUp).Offset(1, 0).Value = "Error in row " & i & " of ColumnNAme"
End If
Next i
End Sub

Excel Load Data button

I have a work sheet (Stored Jobs) that I have a macro that will save all the jobs data to. I am now attempting to make a macro that will reload that saved data Based On the job number entered into F9 on the MHBD work sheet the job number sits in column B. I need f to be returned as the row number that the job sits on so that I can copy data from that row into different cells on the MHBD sheet. I cant just copy the row straight because the data on the MHBD sheet is not in a row its scattered. How do I get it to return the row that the job lives on and use that to copy cells off of that row?
Sub Load_Button()
Dim StoredJobs As Worksheet
Dim MHBD As Worksheet
Dim lastRow As Long
Dim f As Range, theJob
Set StoredJobs = Worksheets("Stored Jobs")
Set MHBD = Worksheets("Manual Hour Break Down")
lastRow = StoredJobs.Range("B" & Rows.Count).End(xlUp).Row
theJob = MHBD.Range("F9").Value
'find the current job if it exists
Set f = StoredJobs.Range("B4:B" & lastRow).Find(what:=theJob, lookat:=xlWhole).Row
'if not found, use the next empty row
If f Is Nothing Then MsgBox "Job has not been entered."
End Sub
Got it. #johnColeman you were correct on removing .Row
Thanks everyone else for the ideas and help.
Sub Load_Button()
Dim StoredJobs As Worksheet
Dim MHBD As Worksheet
Dim lastRow As Long
Dim f As Range, theJob
Set StoredJobs = Worksheets("Stored Jobs")
Set MHBD = Worksheets("Manual Hours Break Down")
lastRow = StoredJobs.Range("B" & Rows.Count).End(xlUp).Row
theJob = MHBD.Range("F9").Value
'find the current job if it exists
Set f = StoredJobs.Range("B4:B" & lastRow).Find(what:=theJob, lookat:=xlWhole)
'if not found, error message
If f Is Nothing Then
MsgBox "Job: " & MHBD.Range("F9").Value & " has not been entered" & vbNewLine & "Try the Quote Number"
'if found, copy data
Else
StoredJobs.Range("C" & (f.Row)).Copy
MHBD.Range("B3").PasteSpecial xlPasteValues
End If
End Sub

Copy/Paste multiple rows in VBA

I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With

Using VBA - Insert VLOOKUP depending on certain values

I am trying to retrieve data from another file using the VLOOKUP function however this is only to happen depending on if any of the 3 items of data appear in column 8(H)
OLY
OLY - QUO
OLY - PRO
I have the following and know this is not correct
Sub BlockAllocationsVlookupAll()
Dim x As Long
For x = 1 To 65536
If InStr(1, Sheet1.Range("$H$" & x), "OLY") > 0 Then
Sheet1.Range("$I$" & x) = Sheet1.Range("$I$" & x) & "sometext"
End If
Next
End Sub
I know the above doesn't do exactly what I need can anyone help as to what needs to be edited to include the Vlookup below
=VLOOKUP(A21,'[001 - Allocations - Blocks.xls]CurrentDayAll'!$1:$65536,9,FALSE)
The other issue is that the cell the VLOOKUP points to first will also change due to the varying length of the report
Thank you for any help given
UPD:
As follows up from comments,
column H is in Allocations.xls workbook
there are a set of criterias
formula should be placed in cell only if corresponding cell in column H matches any of thouse criterias.
Working code:
Sub BlockAllocationsVlookupAll()
Dim x As Long
Dim lastrow As Long
Dim searchCriterias As String
Dim wb As Workbook
Dim ws As Worksheet
'specify correct path to your workbook
Set wb = Workbooks.Open("C:\Allocations.xls")
'If workbook is already opened use next line
'Set wb = Workbooks("Allocations.xls")
Set ws = wb.Worksheets("Current Day")
searchCriterias = "|OLY|SVC|SVC-PRO|SVC-QUO|EUR|EUR-PRO|EUR-QUO|"
With ws
lastrow = .Cells(.Rows.Count, "H").End(xlUp).Row
For x = 4 To lastrow
If InStr(1, searchCriterias, "|" & .Range("H" & x) & "|") > 0 Then
.Range("I" & x).Formula = "=VLOOKUP(A" & x & ",'[001 - Allocations - Blocks.xls]CurrentDayAll'!$A:$I,9,FALSE)"
End If
Next
End With
'Comment next line if you don't want to close wb
wb.Close (True)
Set wb = Nothing
End Sub

How to return value from VLOOKUP into a cell?

I have the following piece of code for Vlookup. The function works fine but the found out value aint getting displayed in the cell. However if i had a used Msgbox function the found out value is shown. The question is doesnt VLOOKUP result be captured in a cell?
Sub Example_of_Vlookup()
Dim lookFor As Range
Dim rng As Range
Dim col As Integer
Dim found As String
Dim lastrowrange As Long
Dim area As Range
lastrowrange = [A65536].End(xlUp).Row
Set lookFor = Sheets("Sheet2").Range("b2")
Set rng = Sheets("Sheet2").Columns("t:u")
Set taxRange = Range("f2", Cells(lastrowrange, 22))
col = 2
On Error Resume Next
For i = 1 To lastrowrange
found = Application.VLookup("B2", "T1:U4", 2, True)
If IsError(found) Then
MsgBox lookFor & " not found"
Else
area.Cells(i, 2).Value = found
End If
Next i
On Error GoTo 0
End Sub
You did not set the range "area" equal to anything, so this line won't show your answer properly:
area.Cells(i, 2).Value = found
Change area.Cells(i,2).value to sheets("Sheet2").Cells(i,2).value or wherever you want your answer to show. Or, set area equal to something if you want to use area.cells.
Idea is simple - I have country names in Column B.Inention is to pull out the Area under which country belongs - My look up values are in column S(country) and T(area) and display the result in column F – Sayanth Sasidharan 25 mins ago
If my understanding is correct as per your explanation then you do not need to use a loop. Let Excel do the Dirty Work ;) You will end up with far less code.
Let's say your sheet looks like this
Logic:
Find the last row of Col B
Insert the Vlookup formula in F1:F & LastRow in one go
Convert them to values.
Code:
Option Explicit
Sub Example_of_Vlookup()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> =IF(ISERROR(VLOOKUP(B1,S:T,2,0)),"",VLOOKUP(B1,S:T,2,0))
.Range("F1:F" & lRow).Formula = _
"=IF(ISERROR(VLOOKUP(RC[-4],C[13]:C[14],2,0)),"""",VLOOKUP(RC[-4],C[13]:C[14],2,0))"
.Range("F1:F" & lRow).Value = .Range("F1:F" & lRow).Value
End With
End Sub
Result: