Create new Excel workbook and copy information with certain characteristics - vba

I'm interning and was given an assignment in VBA, which I know very little about. I found code that is similar to the functions I need and have commented it with my best guesses. If you could help me understand what each piece does and where to replace the generic code with my own information, it would be greatly appreciated!
When patrons have an overdue record, they are sent a spreadsheet with a list of the records they must return and the records' attributes in the following columns.
I need to create a macro which will
Create a new workbook
Copy row 1 (headings)
Copy rows with the same User
Name the file “UniqueUserrecordsrecall.xlsx”
Save to C:\Users\xxx\Documents\xxx\xxx
Attributes: Records, Description, Client, Engagement, Days, Date, Type, LOS, Location, State, Final, User.
Workbook Name: RecordsRecall
Worksheet Name: Main
Sub details()
'Declaration
Dim thisWB As String
Dim newWB As String
thisWB = ActiveWorkbook.Name
'?
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
'CreateTempSheet
Sheets.Add
ActiveSheet.Name = "tempsheet"
'?
Sheets("Main").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End If
'Copy User Column
Columns("L:L").Select
Selection.Copy
'Paste User Column in TempSheet
Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'?
If (Cells(1, 1) = "") Then
LastRow = Cells(1, 1).End(xlDown).Row
If LastRow <> Rows.Count Then
Range("A1:A" & LastRow - 1).Select
Selection.Delete Shift:=xlUp
End If
End If
'Apply Unique Filters in Tempsheet
Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), Unique:=True
'?
Columns("A:A").Delete
Cells.Select
Selection.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
For suppno = 2 To lMaxSupp
Windows(thisWB).Activate
supName = Sheets("tempsheet").Range("A" & suppno)
If supName <> "" Then
Workbooks.Add
ActiveWorkbook.SaveAs supName
newWB = ActiveWorkbook.Name
Windows(thisWB).Activate
Sheets("Main").Select
Cells.Select
If ActiveSheet.AutoFilterMode = False Then
Selection.AutoFilter
End If
Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
Operator:=xlAnd, Criteria2:="<>"
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
'Copy from TempSheet
Rows("1:" & LastRow).Copy
'Paste in newWB in TempSheet
Windows(newWB).Activate
ActiveSheet.Paste
'Save and Close newWB
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
Next
'Delete TempSheet
Sheets("tempsheet").Delete
Sheets("Main").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
ActiveSheet.ShowAllData
End If
End Sub
Thanks for the help!

I am guessing this code does not achieve the effect you seek and you do not know where to start fixing it.
You are attempting too much in one go when you do not really know what you are doing.
I suggest you start by writing simple macros each of which achieves one step of your total requirement or adds one step to a previous macro. If you run into difficulties with one of these macros, you can post it with an explanation of what it does and what you want it to do. Questions with macros that isolate a single problem get answered very quickly. I would not know where to start debugging your current macro.
You have an AutoFilter but I cannot see how that selects the records of a patron with an overdue record. I think that is your first problem: how does the macro know which patron’s records are to be output? Could this be supName? Where has this come from?
Can you write a macro that creates an empty workbook and saves it with the desired name? Call that Macro1.
Write Macro2 by updating Macro1, to rename Sheet1 as “Overdue” or something more meaningful and then delete the other worksheets.
Can you write a macro that uses AutoFilter to select the required records? Write this as new macro Macro3.
Merge Macro2 and Macro3 and try copying the rows selected by AutoFilter to the new workbook. The statement SourceRange.Copy Destination:=FirstDestCell is likely to be easier to use than Copy and Paste.
I hope you can see why little macros which expand your knowledge one step at a time will be an easier path to your objective than trying to debug your current code.

Related

vba countif for duplicates when validating another data

I'm trying to copy data into new workbook and validate the data by removing duplicates keeping one cell value as the source.
All I wanted is the count of XD in the worksheet provided there are no duplicate Record locator.
Also I wanted the count to be in a msgbox. Can someone help ?
Sub openworkbook()
Workbooks.Open ("C:\Users\kjayachandiran\Desktop\ACUITY CF 1204-1210.xls")
Worksheets(2).Activate
Cells.Select
Selection.Copy
Workbooks.Open ("C:\Users\kjayachandiran\Desktop\New-Manjunath.xlsx")
Worksheets(1).Activate
Range("A1").Select
ActiveSheet.Paste
Workbooks(3).Save
Workbooks(2).Close
ActiveWorkbook.Activate
Worksheets(1).Activate
Cells(1, 1).Select
Range("A366655").Value = Application.WorksheetFunction.CountIf(Columns(9), "=" & "XD")
End Sub

Need help correcting a VBA/Macro code to combine multiple tabs into one

I am new to VBA and have primarily used it in conjunction with creating a macro. As you can see from the code below, I am trying to take tables from three different tabs and merge them into one. However, I am having a hard time understanding how to ensure that each table will paste directly underneath the previous table and not overwrite it (especially when each month new rows are created).
Thank you in advance for any help you can provide.
' Step_4_Combination_Tab Macro
Sheets("Past Data").Select
Range("A2:M2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Combination").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Selection.End(xlDown).Select
Range("A5483").Select
Sheets("Actual").Select
Range("A5:M5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Combination").Select
Range("A5483").Select
ActiveSheet.Paste
Range("A5483").Select
Selection.End(xlDown).Select
Range("A8341").Select
Sheets("Forecast").Select
Range("A4:M4").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Combination").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
End Sub
The following code might do what you want:
Sub mergeSheets()
Set targetSheet = Sheets("Combination")
For i = 1 To Sheets.Count
If Sheets(i).Name <> "Combination" Then
Last = LastRow(Sheets("Combination"))
Sheets(i).UsedRange.Copy targetSheet.Cells(Last + 1, 1)
End If
Next i
End Sub
Function LastRow(sh As Worksheet)
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End Function
some codebits taken from here https://www.exceltip.com/cells-ranges-rows-and-columns-in-vba/copy-the-usedrange-of-each-sheet-into-one-sheet-using-vba-in-microsoft-excel.html
You will need to find the last row that has data and paste you next table there.
LR = Sheets("Combination").Range("A" & Rows.Count).End(xlUp).Row
Pasterange = "A" & LR
Sheets("Combination").Range(Pasterange).Paste
I am guessing that you want to copy data from tabs "Past data", "Actual" and "Forecast" to "Consolidated". Am I right? And for some odd reason data in source worksheets begins in different rows. I would do it this way:
Sub AllToCons()
CopyToCons "Past data", 2
CopyToCons "Actual", 5
CopyToCons "Forecast", 4
End Sub
Sub CopyToCons(wsName As String, lRow As Long)
'wsName: name of sheet we are copying from
'lRow: number of row where data start
Dim ws As Worksheet
Dim wsCons As Worksheet
Dim rng As Range
Set wsCons = ThisWorkbook.Worksheets("Consolidated")
Set ws = ThisWorkbook.Worksheets(wsName)
With ws
Set rng = Range(.Range("A" & lRow), .Range("M" & .Cells.Rows.Count).End(xlUp))
End With
rng.Copy
With wsCons
.Range("A" & .Cells.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End With
If you want to paste values only, type xlPasteValues instead of xlPasteAll.
Hope it helped.

Removing the border lines in a worksheet when code has been run

I have a code that successfully looks into an external file and copy/pastes the rows that contain that particular condition into the current workbook. For example I am searching for Singapore in the external workbook called Active master project file and copy all the rows containing Singapore to the current workbook that is open.
A problem that occurs is that when I run the same code twice, a border line will exist on the last row of the worksheet. For example when I run the code, it will copy paste the information containing Singapore to the current worksheet called "New Upcoming Projects":
However, when I run the code again it will create a border line on each column such as the image shown below:
And the code that I have for now is:
Sub UpdateNewUpcomingProj()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As String
Set wb1 = Application.Workbooks.Open("U:\Active Master Project.xlsm")
Set ws1 = wb1.Worksheets("New Upcoming Projects")
strSearch = "Singapore"
With ws1
'~~> Remove any filters
.AutoFilterMode = False
'~~> I am assuming that the names are in Col A
'~~> if not then change A below to whatever column letter
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("New Upcoming Projects")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 2
End If
copyFrom.Copy .Rows(lRow)
.Rows.RemoveDuplicates Array(2), xlNo
End With
End Sub
Is there any improvement or additional codes that I have to add in so that the border line would disappear?
As EyePeaSea said you can remove the border by vba code, e.g.
ThisWorkbook.Worksheets("XY").Range("A1", "Z99").Borders.LineStyle = xlNone
In your case the code should be (untested)
copyFrom.Borders.LineStyle = xlNone
after you copied the row
I assume this formatting is coming from the source worksheet. If so, you could PasteSpecial to just paste values, keeping the destination formatting. To do so, simply replace
copyFrom.Copy .Rows(lRow)
with
copyFrom.Copy
.Rows(lRow).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
If you do need some formatting from the source sheet, you can use xlPasteAllExceptBorders instead of xlPasteValues.
Paste Special, this will paste to the first empty cell in column A
copyfrom.Copy
ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = 0
You can add this line after removing the duplicates
.UsedRange.Offset(lRow).Borders.Value = 0
This will remove any borders from the inserted rows
p.s.: I still dont understand where these borders came from, most probably from the original worksheet.. :)
At the end of the code,
please add a new line to format paint of the 3rd row.
So basically before the last two lines
wb1.Select ' please make sure you select the correct one wb1 or wb2 here and try again
Rows("3:3").Select
Selection.Copy
Rows("4:10000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
end with
end sub 'This is the last line of your code

VBA Prompt user to choose Excel sheet

I used Macro Recorder in Excel to record a series of tasks I need to automate. These tasks happen between two different Excel spreadsheets. I believe that the macro performs the code on the current worksheet, but right now the second sheet is hard coded. How do I prompt the user to choose an Excel sheet to reference to?
The workbook that is going to have the macro is the MasterHardwareDB & the file that needs to be replaced with a user input is Computer&DeploymentInfo_06_23_15_v3.xlsx
I was researching the filedialog object but I am not sure how to integrate here.
Sub AutomateCompare()
'
' AutomateCompare Macro
'
ActiveCell.Select
ActiveCell.FormulaR1C1 = _
"=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[scheduleddate],MATCH([ #HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
ActiveCell.Offset(1, 0).Range("MasterHardwareDB[[#Headers],[Name]]").Select
ActiveCell.FormulaR1C1 = _
"=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[scheduleddate],MATCH([#HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
ActiveCell.Offset(1, 0).Range("MasterHardwareDB[[#Headers],[Name]]").Select
ActiveWindow.SmallScroll ToRight:=-1
ActiveCell.Offset(-2, 1).Range("MasterHardwareDB[[#Headers],[Name]]").Select
ActiveCell.FormulaR1C1 = _
"=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[forecastdate],MATCH([#HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
ActiveWindow.SmallScroll ToRight:=1
ActiveCell.Offset(1, 0).Range("MasterHardwareDB[[#Headers],[Name]]").Select
ActiveWindow.SmallScroll ToRight:=-7
ActiveSheet.ListObjects("MasterHardwareDB").Range.AutoFilter Field:=9, _
Criteria1:="FALSE"
ActiveWindow.SmallScroll ToRight:=1
ActiveCell.Offset(4169, -4).Range("MasterHardwareDB[[#Headers],[Name]:[EmpID]]") _
.Select
ActiveCell.Offset(521, 1).Range("MasterHardwareDB[[#Headers],[Name]]").Select
ActiveWindow.SmallScroll ToRight:=-7
ActiveSheet.ListObjects("MasterHardwareDB").Range.AutoFilter Field:=5, _
Criteria1:="=Scheduled", Operator:=xlOr, Criteria2:="=To Be Scheduled"
ActiveCell.Offset(87, -8).Range("MasterHardwareDB[[#Headers],[Name]]").Select
ActiveWindow.SmallScroll ToRight:=8
End Sub
The easiest way to do this is
shtNum = InputBox("Enter the number of the sheet you want to use.")
With Sheets(shtNum)
Your code here
End With
Also, just so you know, macro recorder code contains a lot of junk. Here is a cleaned-up version of your code.
Sub AutomateCompare()
With ActiveSheet
'Change the ranges to what you need. Using activecell is usually dangerous
.Range("A1:A2").FormulaR1C1 = "=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[scheduleddate],MATCH([ #HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
.Range("B1").FormulaR1C1 = "=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[forecastdate],MATCH([#HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
.ListObjects("MasterHardwareDB").Range.AutoFilter Field:=9, Criteria1:="FALSE"
.ListObjects("MasterHardwareDB").Range.AutoFilter Field:=5, Criteria1:="=Scheduled", Operator:=xlOr, Criteria2:="=To Be Scheduled"
End With
End Sub
Edit: Here is code that opens another workbook
Sub AutomateCompare()
Dim fileBrowse As FileDialog
Dim shtNum As Integer
Set fileBrowse = Application.FileDialog(msoFileDialogOpen)
If fileBrowse.Show = True Then wbPath = fileBrowse.SelectedItems(1)
With Workbooks.Open(wbPath)
shtNum = InputBox("Enter the number of the sheet you want to use.")
With .Sheets(shtNum)
'Change the ranges to what you need. Using activecell is usually dangerous
.Range("A1:A2").FormulaR1C1 = "=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[scheduleddate],MATCH([ #HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
.Range("B1").FormulaR1C1 = "=INDEX('Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[forecastdate],MATCH([#HostName],'Computer&DeploymentInfo_06_23_15_v3.xlsx'!Table1[computername],0))"
.ListObjects("MasterHardwareDB").Range.AutoFilter Field:=9, Criteria1:="FALSE"
.ListObjects("MasterHardwareDB").Range.AutoFilter Field:=5, Criteria1:="=Scheduled", Operator:=xlOr, Criteria2:="=To Be Scheduled"
End With
End With
End Sub

Copy cells by row containing text to column on another worksheet

I'm fairly new to macros etc..and I've been trying to figure this problem out for a few days now!
I'm trying to go from a large spreadsheet of data, selecting specific cells based on the contents of specific cells, and paste into another worksheet.
Source spreadsheet:
Columns go: Site, Sub-location, Date, Month, Inspector, Action 1, Action 2 etc up to a max of 67 actions for each inspection.
Each row is a separate inspection submission
Target spreadsheet:
Columns go: Site, Sub-location, Date, Month, Inspector, Action, Due date of Action
where each row is a separate action.
I want it to skip pasting any values from the actions columns that would be blank (since no action is required). When it pastes the actions, it will also paste the first 5 columns (with site name, location, date etc), so that the action can be identified to the right site, date etc.
Hopefully that makes sense. By the end, I want the target spreadsheet to be able to be filtered by whatever the people need, e.g. by due date, or by location etc.
Code that I tried my hardest to get working...Unfortunately I can only get it working for the first row, and then it still pastes the blank (or zero) values and I need to filter them out. I'm thinking some sort of loop to do all the rows.
Sub test1257pm()
Application.ScreenUpdating = False
Sheets("Corrective Actions").Select
Range("A3:E3").Select
Selection.Copy
Sheets("Corrective Actions Tracker").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Corrective Actions").Select
Range("F3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Corrective Actions Tracker").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).PasteSpecial
Rows("2:2").Select
Selection.AutoFilter
Range("F4").Select
ActiveSheet.Range("$A$2:$L$300").AutoFilter Field:=6, Criteria1:=Array( _
"CMC to conduct clean of ceiling fans. Close out by 17/04/2014", _
"Provide bins", "Send to contractor", "="), Operator:=xlFilterValues
Application.ScreenUpdating = True
End Sub
Many thanks to anyone that can give me any assistance! :)
Edit:24-4-2014
Okay so after L42's code, it works fine if I could just consodidate my data first before putting it in the 1 column (stacking). The code I tried (using Macro recorder) is:
Sub Macro2()
Dim r As Range
Dim i As Integer
For i = 3 To 10
Range("P" & i).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("F" & i).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=True, _
IconFileName:=False
Next i
End Sub
My problem with this is that it gives unexpected results...it doesn't consolidate it all into rows how I would expect. I'm thinking that this isn't the best solution...and probably the original macro needs to be changed..however I'm not sure how.
Overhaul #1: Using the provided sample data
Option Explicit '~~> These two lines are important
Option Base 1
Sub StackMyActions()
Dim sourceWS As Worksheet, targetWS As Worksheet
Dim staticRng As Range, copyRng As Range
Dim inspCnt As Long, i As Long, fRow As Long, tRow As Long
Dim myactions
Set sourceWS = ThisWorkbook.Sheets("Corrective Actions")
Set targetWS = ThisWorkbook.Sheets("Corrective Actions Tracker")
With sourceWS
'~~> count the total inspection
'~~> here we incorporate .Find method finding the last cell not equal to 0
inspCnt = .Range("A3", .Range("A:A").Find(0, [a2], _
xlValues, xlWhole).Offset(-1, 0).Address).Rows.Count
'~~> set the Ranges
Set copyRng = .Range("F3:BT3")
Set staticRng = .Range("A3:E3")
'~~> loop through the ranges
For i = 0 To inspCnt - 1
'~~> here we use the additional code we have below
'~~> which is GetCARng Function
myactions = GetCARng(copyRng.Offset(i, 0))
'~~> this line just checks if there is no action
If Not IsArray(myactions) Then GoTo nextline
'~~> copy and paste
With targetWS
fRow = .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Row
tRow = fRow + UBound(myactions) - 1
.Range("F" & fRow, "F" & tRow).Value = Application.Transpose(myactions)
staticRng.Offset(i, 0).Copy
.Range("A" & fRow, "A" & tRow).PasteSpecial xlPasteValues
End With
nextline:
Next
End With
End Sub
Function to get the actions:
Private Function GetCARng(rng As Range) As Variant
Dim cel As Range, x
For Each cel In rng
If cel.Value <> 0 Then
If IsArray(x) Then
ReDim Preserve x(UBound(x) + 1)
Else
ReDim x(1)
End If
x(UBound(x)) = cel.Value
End If
Next
GetCARng = x
End Function
Results:
1: Using your sample data which looks like below:
2: Which after running the macro stacks the data like below:
Above code only stack inpections with at least 1 Action.
For example, Site 3 which was conducted by MsExample do not reflect on the Corrective Actions Tracker Sheet since no action was posted.
Well I really can't explain it enough, all the properties and methods used above.
Just check out the links below to help you understand most parts:
Avoid Using Select
Using .Find Method
Returning Array From VBA Function
And of course practice, practice, practice.