Sub Random()
'if you have questions or you broke the macro, reach out to the AU DataDudes!
Dim J As Integer
Dim P As Integer
Dim V As Integer
Dim Production As Worksheet
Dim Distro As Worksheet
Dim IRowL As Integer
Dim ProwL As Integer
Dim StartRange As Range
Set Production = Worksheets("Alias Production Detail Report")
Set Distro = Worksheets("WorkList")
IRowL = Distro.Cells(Distro.Rows.Count, "A").End(xlUp).Row 'if you changed the location of the Name in the Gracie sheet change this
ProwL = Production.Cells(Production.Rows.Count, "A").End(xlUp).Row 'if you change the location of the name in the master sheet change this
Application.ScreenUpdating = False
For J = 2 To IRowL
For P = 2 To ProwL
If Distro.Cells(J, 1).Value = Production.Cells(P, 6).Value Then
If Production.Cells(P, 5).Value <> Distro.Cells((J - 1), 5).Value Then
Production.Cells(P, 1).EntireRow.Copy
Distro.Cells(J, 1).Select
ActiveSheet.Paste
Exit For
End If
End If
Next P
Next J
Application.ScreenUpdating = True
MsgBox ("All Done!")
Did a super primitive approach to a small equivalent for VBA but it will only work for instances of 2,
If Production.Cells(P, 5).Value <> Distro.Cells((J - 1), 5).Value
Can someone provide the approach/thought process regarding using small within the loop resulting can continually get the next instance instead of the same one over and over.
Related
I have written this code to eliminate columns based on header names. On one workbook I have the list of headers to delete, and on the other workbook I have the columns themselves.
'setup
Dim nominas_ws As Worksheet
Set nominas_ws = ActiveSheet
Dim conceptos_wb As Workbook
Set conceptos_wb = Workbooks.Open("C:\Users\deepw\Desktop\nominas\conceptos.xlsx")
Dim conceptos_ws As Worksheet
Set conceptos_ws = conceptos_wb.Worksheets(1)
Dim nominas_last_row, nominas_last_column, conceptos_last_row, conceptos_last_column As Long
nominas_last_row = nominas_ws.Cells(Rows.Count, 5).End(xlUp).Row
nominas_last_column = nominas_ws.Cells(1, Columns.Count).End(xlToLeft).Column
conceptos_last_row = conceptos_ws.Cells(Rows.Count, 5).End(xlUp).Row
conceptos_last_column = conceptos_ws.Cells(1, Columns.Count).End(xlToLeft).Column
'delete names & unwanted columns
nominas_ws.Range("C2:C" & nominas_last_row).ClearContents
Dim conceptos_headers As Range
Dim i, c As Integer
Dim concepto_input As String
For i = 2 To conceptos_last_row
concepto_input = conceptos_ws.Cells(i, 1).Value
For c = 1 To nominas_last_column
If Cells(c, 1).Value = "concepto_input" Then Cells(c, 1).EntireColumn.delete
Next c
Next i
Thank you in advance for your help.
If Cells(c, 1).Value = "concepto_input" Then
you are checking for the string literal "concepto_input", not the value in the variable concepto_input. Should be:
If Cells(c, 1).Value = concepto_input Then
If there might be multiple matches for any given column heading, you should loop backwards:
For i = 2 To conceptos_last_row
concepto_input = conceptos_ws.Cells(i, 1).Value
For c = nominas_last_column To 1 Step -1
If conceptos_ws.Cells(c, 1).Value = concepto_input Then
conceptos_ws.Columns(c).Delete
'Exit For 'if there can only be one match per search term
End If
Next c
Next i
Note it's also good practise to never use Range/Cells without an explicit worksheet qualifier.
In sheet 2 of my workbook, I have names of employees, the dates they came into work, the shifts they worked, and absenteeism. In sheet 1 of my code, I have a lookup sheet where I intend for the employee's name to be typed into a cell and to show all the dates and this person worked, along with the shift and absenteeism into the lookup sheet. I've tried a vriaty of things, but this is my current code:
Private Sub worksheet_change(ByVal Target As Range)
Dim Lookup As Worksheet
Dim Data As Worksheet
Dim LastRow As Long
Dim V As Range
Set Lookup = ThisWorkbook.Worksheets("Lookup")
Set Data = ThisWorkbook.Worksheets("Data")
Set V = Lookup.Range("A1:A2")
LastRow = Data.Cells(Rows.Count, "A").End(xlUp).Row
LookupCounter = 2
For i = 2 To LastRow
If Intersect(V, Target) Is Nothing Then
Lookup.Range("B2:C2000").Delete
ElseIf Lookup.Range("A2") = Data.Cells(i, 2) Then
Lookup.Cells(LookupCounter, 2).Value = Data.Cells(i, 1)
Lookup.Range("B2:B2000").NumberFormat = "mm/dd/yyyy"
Lookup.Cells(LookupCounter, 3).Value = Data.Cells(i, 9)
LookupCounter = LookupCounter + 1
End If
Next i
End Sub
My intention is for when a new name is typed, this clears the info from the columns of the lookup page, and inputs the new data for the new name. The second part of my code where I match the names to the dates works, but I am struggling with the clearing function. What can I do to fix it?
Option Explicit
Private Sub worksheet_change(ByVal Target As Range)
Dim Lookup As Worksheet, Data As Worksheet
Dim LastRow As Long, LookupCounter As Long, i As Long
With ThisWorkbook
Set Lookup = .Worksheets("Lookup")
Set Data = .Worksheets("Data")
End With
If Intersect(Lookup.Range("A1:A2"), Target) Is Nothing Then
Exit Sub
Else
' clear sheet
Lookup.Range("B2:C2000").Delete
LastRow = Data.Cells(Rows.Count, "A").End(xlUp).Row
LookupCounter = 2
' get data
For i = 2 To LastRow
If Data.Cells(i, 2) = Lookup.Range("A2") Then
Lookup.Cells(LookupCounter, 2).Value = Data.Cells(i, 1)
Lookup.Cells(LookupCounter, 3).Value = Data.Cells(i, 9)
LookupCounter = LookupCounter + 1
End If
Next
Lookup.Range("B2:B2000").NumberFormat = "mm/dd/yyyy"
End If
End Sub
I'm writing a VBA program which copies and organizes data from one master sheet into numerous other sheets. One of the recipient sheets unifies all the data from the master sheet which holds the same id number into a single row. For this operation, I am looping through the master sheet for each id number, copying each row which holds the current id number into a new sheet purely used for calculations and organizing, and rearranging the data in this sheet into the new row. The resultant row is copied into the recipient sheet. This process of organizing data for every id number takes a long time to process, especially given the very large size of this sheet and the processing time of the other recipient sheets. I'm wondering if there is a better way to organize and copy data without using an intermediate calculation sheet.
The below code is the main sub, which calls another sub OrganizeAndCopyToPal, which organizes the data in the calculation sheet and copies the result into the recipient sheet.
Sub PalletAssemblyLog()
Dim allidNum As Range
Dim curridNum As Range
Dim rowCount As Long
Dim idNum
Dim I As Long
Dim j As Long
Dim machineLoc As String
Dim calc As Worksheet
Dim full As Worksheet
Dim pal As Worksheet
Set calc = Sheet3
Set full = Sheet4
Set pal = Sheet1
For I = 2 To rowCount
For j = 2 To rowCount
If full.Cells(j, 17).Value = idNum Then
If allidNum Is Nothing Then
Set allidNum = full.Cells(j, 17)
Else
Set allidNum = Union(allidNum, full.Cells(j, 17))
End If
End If
Next j
Set curridNum = allidNum.EntireRow
calc.Activate
calc.Cells.Clear
full.Activate
curridNum.Copy calc.Range("A1")
OrganizeAndCopyToPal curridNum
Next I
End Sub
The below sub organizes and copies the data for each id number. The final sub to copy the data isn't related to the matter of simplifying this task so I'm not including it.
Sub OrganizeAndCopyToPal(curridNum)
Dim calc As Worksheet
Dim pal As Worksheet
Set calc = Sheet3
Set pal = Sheet1
calc.Activate
Dim rowCount As Long
rowCount = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim palRow As Long
palRow = rowCount + 2
Dim partRow As Long
partRow = palRow + 2
Dim currPartCount As Range
Dim assembly As String
Dim id As String
Dim location As String
Dim machType As String
Dim machLoc As String
Dim currPart As String
Dim link As String
Dim tot As Long
tot = 0
With calc
.Cells(1, 1).Copy .Cells(palRow, 2)
assembly = .Cells(1, 1).Value
.Cells(1, 2).Copy .Cells(palRow, 5)
id = .Cells(1, 17).Value
asArray = SplitMultiDelims(id, "|-")
'MsgBox asArray(0) & " " & asArray(1) & " " & asArray(2)
machArray = Split(.Cells(1, 8), "-")
machType = machArray(0)
.Cells(palRow, 3) = machType
machLoc = .Cells(1, 8).Value
.Cells(palRow, 4) = machLoc
.Cells(1, 17).Copy .Cells(palRow, 10)
location = Cells(1, 9)
.Cells(palRow, 1) = location
For I = 1 To rowCount
partArray = Split(.Cells(I, 16).Value, ",")
For j = 0 To UBound(partArray)
partArray2 = Split(partArray(0), "-")
partPrefix = partArray2(0)
If j = 0 Then
currPart = partArray(j)
Else
currPart = partPrefix & "-" & CStr(partArray(j))
End If
tf = 1
For k = 0 To tot
If Cells(partRow + k, 1).Value = currPart Then
tf = 0
Exit For
End If
Next k
If tf = 1 Then
.Cells(partRow + tot, 1).Value = currPart
tot = tot + 1
End If
Next j
Next I
For I = 1 To tot
Cells(palRow, 10 + I).Value = Cells(partRow + I - 1, 1)
Next I
End With
CopyToPal curridNum, palRow
End Sub
Thank you for any tips or help that you can offer.
Before getting into more exotic solutions - the easiest thing you can do is set
Application.Calculation = xlCalculationManual
Before getting stuck into much code.
Then when you need to do an update before copying any data that may change due to formulae calcs, run
Application.Calculate
and eventually at the end reset it to
Application.Calculation = xlCalculationAutomatic
You can disable screen updates too, but the above will be the big (easy) one. After that we're into copying to arrays and working in them then pasting back.
I'm having trouble with this VBA - my for loop only iterates once, and when it increments it says that the method "Cells" in object "Worksheet" failed. It worked the first iteration though... I think my StatusUpdate function is breaking it, but when I comment it out, it fails anyway. Does anything stand out in the main sub to anyone? Happy to post more code if needed.
Sub CreateSlides()
Dim XLapp As New Excel.Workbook
Dim WS As New Excel.Worksheet
Set XLapp = Excel.Workbooks.Open("J:\OPERATIONS\CAPITAL PROJECTS\Clara\test.xlsx")
Set WS = XLapp.Sheets(1)
XLapp.Activate
WS.Select
Dim CD As Integer
CD = 0
Dim cell As Range
Dim i As Integer
Dim LastRow As Integer
LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
'Delete old slides
If ActivePresentation.Slides.Count > 1 Then
Call DeleteSlides
End If
'Loop through each used row in Column A
For i = 2 To LastRow
CD = WS.Cells(i, 35).Value
ActivePresentation.Slides(1).Copy
ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1)
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("project").TextFrame.TextRange = WS.Cells(i, 7).Value
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("park location").TextFrame.TextRange = WS.Cells(i, 9).Value
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("cb").TextFrame.TextRange = Right(WS.Cells(i, 36).Text, 2)
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("cm").TextFrame.TextRange = (CouncilMember(CD))
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("scope").TextFrame.TextRange = WS.Cells(i, 8).Value
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("funding").TextFrame.TextRange = FundingEst(i)
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes("status").TextFrame.TextRange = StatusUpdate(i)
Next
End Sub
you a re not running through column a but to the 35th column in the sheet. change
CD = WS.Cells(i, 35).Value
to
CD = WS.Cells(i, 1).Value
Also, if whatever is in those cells is not an integer, but text or something else, you will get an error?
I am new to VBA and I have been using the great help within this site, to create a macro to take a list of numbers from one sheet (Sheet 14), remove the duplicates and paste within another sheet (Sheet 2).
I am hoping to take this further by rather than pasting the cells one after another I am looking to have the list pasted in alternate rows i.e D10, D12, D14 etc.
I have tried various methods from within this site, however to no avail. I have used different types of "Step" functions but I am struggling to incorporate this within the below coding.
Any help is much appreciated!
Below is what I have at the moment:
Sub RUN()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Sheet14.Activate
lastRow = Sheet14.Cells(Rows.Count, "F").End(xlUp).Row
On Error Resume Next
For i = 3 To lastRow
If Len(Cells(i, "F")) <> 0 Then
dictionary.Add Cells(i, "F").Value, 1
End If
Next
Sheet2.Range("d10").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
MsgBox dictionary.Count & " RUN TEMPLATES."
End Sub
Here's one approach (BTW, I wouldn't call a macro RUN):
Sub ListUniques()
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Dim vKeys
Application.ScreenUpdating = False
Set dictionary = CreateObject("scripting.dictionary")
With Sheet14
lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 3 To lastRow
If Len(.Cells(i, "F")) <> 0 Then
dictionary(.Cells(i, "F").Value) = 1
End If
Next
End With
vKeys = dictionary.keys
For i = LBound(vKeys) To UBound(vKeys)
Sheet2.Range("d10").Offset(2 * i).Value = vKeys(i)
Next i
Application.ScreenUpdating = True
MsgBox dictionary.Count & " RUN TEMPLATES."
End Sub