Posts by gijsmo
-
-
To avoid skipping over the first value when using Find, set the After parameter to last cell in the range eg:
Code -
Not sure what the purpose is of asking the user to specify a filename in the following code:
It just seems to be a trigger to confirm saving the file.
xFileName is not used in the code, the following code overrides whatever filename is chosen with the value of ThisFile:
The only thing I can see that GetSaveAsFilename will do is maybe change the destination folder of the saved file.
-
Without changing loads of code you've already created, one way to do this could be as follows in place of your "For" loop in the AddRecord routine.
Code- With ActivePage.Controls
- 'write the calculated fields out first
- NewRecord.Offset(ColumnOffset:=20).Value = .Item("txtPOut").Value
- NewRecord.Offset(ColumnOffset:=21).Value = .Item("txtTReject").Value
- 'then write the entered values and clear the control
- NewRecord.Offset(ColumnOffset:=1).Value = .Item("txtDate").Value
- .Item("txtDate").Value = ""
- NewRecord.Offset(ColumnOffset:=3).Value = .Item("comboShift").Value
- .Item("comboShift").Value = ""
- NewRecord.Offset(ColumnOffset:=4).Value = .Item("txtTechnican").Value
- .Item("txtTechnican").Value = ""
- 'repeat for the rest of the control values to be written to the sheet
- End With
-
The values of Production Output and Total Rejection are calculated fields, derived from the Material In and Reject values.
The AddRecord code is clearing controls:
Therefore, Material In and Reject values are being cleared after being written out to the sheet which is resetting the Production Output and Total Rejectionvalues to 0 before being those values get written to the sheet.
Rather than looping through the controls, might be best (and more efficient) to write out the specific control values to the sheet.
-
You seem to be wanting to copy a column from one workbook to another however you also mention NB:NG which is obviously multiple columns.
To create a range for the single column containing the "ORGANIZATIONRow1_2" header ie, from the header row (row 1) to the last row in the column, try the following (the range rCopy contains the data to be copied).
Code- Sub ColToCopy()
- Dim org1 As Range, rCopy As Range
- Dim lCol As Long, lLast As Long
- With Workbooks("1.xlsx").Sheets(1).Range("A1:ZZ1")
- 'find the header col
- With .Range("A1:ZZ1")
- 'ORGANIZATIONRow1_2 being the heading in the first row of the column containing the data
- Set org1 = .Find("ORGANIZATIONRow1_2")
- End With
- If Not org1 Is Nothing Then
- lCol = org1.Column
- 'find the last row in the specified range
- lLast = .Cells(.Rows.Count, lCol).End(xlUp).Row
- 'create a column range to copy
- Set rCopy = .Range(.Cells(1, lCol), .Cells(lLast, lCol))
- MsgBox rCopy.Address '<-- for debugging, show the range to be copied
- End If
- End With
- End Sub
-
Thanks! You are welcome.
-
Try the attached, code has been added to the Worksheet Change event for the 'Players' sheet.
-
Try this
Code- Sub FetchFileNames()
- Dim FSO As Object, folder1 As Object, fil As Object
- Dim FolderPath_1 As String, Ext As String
- Dim Movenamelist As Workbook
- Dim Last As Long
- Set FSO = CreateObject("Scripting.FileSystemObject")
- FolderPath_1 = "D:\Test\Select\Temp\"
- Set folder1 = FSO.GetFolder(FolderPath_1).Files
- Workbooks.Add
- Set Movenamelist = ActiveWorkbook
- For Each fil In folder1
- Ext = FSO.GetExtensionName(fil)
- If UCase(Ext) = "PDF" Then
- With Movenamelist.ActiveSheet
- Last = .Cells(.Rows.Count, "A").End(xlUp).Row
- If .Range("A" & Last).Value <> "" Then Last = Last + 1
- .Range("A" & Last).Value = fil
- End With
- End If
- Next
- Movenamelist.SaveAs FileName:=FolderPath_1 & "Final.xlsx"
- End Sub
-
The StatusBar showing as TRUE is fixed by changing the code at the top from:
to:
Also, you should add
to the group of code at the bottom of the routine to turn it back off.
Not sure why it would only show 100% though.
One other thing to try - this used to be done easily with VBA Code Cleaner but you can also do it manually.
Save a copy of your file as an .XLSX file, thereby removing all the macro code.
Then re-open the .XLSX file and copy/paste the macro code back in. This can be a bit time consuming if you have code in multiple modules but it might help 'reset' Excel, a lot of 'trash' can build up especially if you've been making lots of code changes and/or running the code for a while.
When you've pasted the code back in, save it back as an .XLSM file.
-
I cannot see any obvious reasons for the code to cause a memory loss/crash.
A variant of the main routine which may speed things up a bit is below.
I've made no changes to the GetFiles routine other than some formatting for readability.
Code- Private Function GetFiles(sPATH As String, Optional sEXT As String) As Variant
- Dim sFileName As String
- With CreateObject("Scripting.Dictionary")
- If sEXT = vbNullString Then
- sFileName = Dir(sPATH, vbNormal)
- Else
- sFileName = Dir(sPATH & "\*." & sEXT & "*", vbNormal)
- End If
- Do While Not sFileName = vbNullString
- .Item(sPATH & "\" & sFileName) = Empty
- sFileName = Dir
- Loop
- GetFiles = .keys
- End With
- End Function
- Sub BuySellSignalsModified()
- Dim StartTime As Double
- Dim v As Variant, f As Variant
- Dim i As Long, j As Long, k As Long, lRow As Long, ws As Worksheet
- Const sPATH As String = "c:\vba"
- Const sEXT As String = "csv"
- StartTime = Timer
- With Application
- .ScreenUpdating = False
- .DisplayAlerts = False
- .EnableEvents = False
- .Calculation = xlCalculationManual
- .ShowWindowsInTaskbar = False
- .StatusBar = True
- End With
- Set ws = Workbooks("MasterFile - Copy.xlsm").Worksheets("MasterSheet")
- ws.Cells.Clear
- v = GetFiles(sPATH, sEXT)
- j = UBound(v) - LBound(v) + 1
- k = 0
- For Each f In v
- With Workbooks.Open(f).Worksheets(1)
- k = k + 1
- Application.StatusBar = "Processing: " & Format(k / j, "0.000%") & " completed" 'comment out if not required
- DoEvents '<--- required to show change in statusbar, comment out if not required
- .Range("I1:O1").Value = Array("V/SMA10", "Vol/Change%", "SMA10", "SMA30", "BUY/SELL SMA10 CROSSOVER", "", "Close/Change%")
- .Range("I2").Formula = "=AVERAGE(H2:H11)"
- .Range("J2").Formula = "=(H2-I2)/I2"
- .Range("K2").Formula = "=AVERAGE(G2:G11)"
- .Range("L2").Formula = "=AVERAGE(G2:G31)"
- .Range("M2").Formula = "=IF(AND(K2>L2,K3<L3,L2>L3),""BUY"",IF(AND(F2<I2,F3>I3),""SELL"",""""))"
- .Range("O2").Formula = "=(G2-G3)/G3"
- .Range("I2:L2").AutoFill Destination:=Range("I2:L1500")
- .Range("M2").AutoFill Destination:=Range("M2:M120")
- .Range("O2").AutoFill Destination:=Range("O2:O1500")
- .Range("I2:O1500").Calculate
- .Columns("I:I").NumberFormat = "General"
- .Columns("J:J").NumberFormat = "0.00%"
- .Columns("O:O").NumberFormat = "0.00%"
- .Columns("K:L").NumberFormat = "0.00$"
- .UsedRange.Columns.AutoFit
- For i = 2 To 2
- If .Cells(i, 13).Value = "BUY" Then
- .Rows(i).Copy
- lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
- With ws.Rows(lRow + 1)
- .PasteSpecial xlPasteValues
- .PasteSpecial xlPasteFormats
- End With
- End If
- Next
- .Parent.Close True
- End With
- Next f
- ws.UsedRange.Columns.AutoFit
- With Application
- .Calculation = xlCalculationAutomatic
- .CutCopyMode = False
- .ScreenUpdating = True
- .DisplayAlerts = True
- .EnableEvents = True
- .ShowWindowsInTaskbar = True
- End With
- MsgBox "This code ran successfully in " & Round(Timer - StartTime, 2) & " seconds", vbInformation
- End Sub
-
There are a number of ways to do this.
Going mostly with the code you have, I have the suggested changes below to the Filter/Extract section.
This requires new variables for wsSht, rRange and rCell.
Code- '---------------------- Now starting the Filter then Extract Sheets based on Filtered Value -----------------------
- Application.ScreenUpdating = False
- 'filters based on what's in the box
- ActiveSheet.Range("$C$6:$N$300").AutoFilter Field:=12, Criteria1:=Filter
- 'create a range of visible cells in the range, ie those that match the Supplier criteria
- Set rRange = ActiveSheet.Range("$C$7:$C$300").SpecialCells(xlVisible)
- For Each rCell In rRange
- If rCell.Value <> "" Then
- Sheet_Name = rCell.Value
- If I = 1 Then
- Sheets(Sheet_Name).Select
- Else
- Sheets(Sheet_Name).Select (False)
- End If
- I = I + 1
- End If
- Next
- 'loop through the selected sheets to copy to output file
- For Each wsSht In ActiveWindow.SelectedSheets
- wsSht.Copy Before:=wb2.Sheets(1) 'copy all the sheets selected to the new workbook
- Next
- Application.ScreenUpdating = True
-
Thank you, you are welcome!
-
An alternative using the Range.Find function to find the max date value is below.
This assumes row under ActiveCell in the ActiveSheet is to be searched.
Code- Sub FindMaxDateInRow()
- Dim wsSht As Worksheet
- Dim lRow As Long, lEnd As Long
- Dim lMax As Long
- Dim rRange As Range
- 'assume activesheet is to be used
- Set wsSht = ActiveSheet
- 'assume row under activecell is to be searched
- lRow = ActiveCell.Row
- With wsSht
- 'determine last column in this row
- lEnd = .Cells(lRow, .Columns.Count).End(xlToLeft).Column
- 'create a range representing the row
- 'this includes column A, adjust if necessary
- 'any text in column A will however be ignored for Max function
- Set rRange = .Range(.Cells(lRow, "A"), .Cells(lRow, lEnd))
- 'work out the maximum date value
- lMax = Application.WorksheetFunction.Max(rRange)
- 'search for this value in the row
- Set rRange = rRange.Find(CDate(lMax), LookIn:=xlValues, LookAt:=xlWhole, _
- SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
- 'jump to the max value cell and display a message
- If Not rRange Is Nothing Then
- Application.Goto wsSht.Cells(lRow, rRange.Column), False
- MsgBox "Max date found in" & vbLf & "Row: " & lRow & " Column: " & rRange.Column
- End If
- End With
- Set rRange = Nothing
- Set wsSht = Nothing
- End Sub
-
Based on your sample workbook, I've attached a macro file that can do the sums on the Master sheet.
Just click the button on the Master sheet to test it.
-
This request comes up fairly frequently on the forums.
A while back I wrote a generic multi workbook copy standalone macro that can:
- Copy a single (specified) sheet from each workbook into a single workbook
If no sheet name is specified, the first sheet in the workbook is assumed - Optionally copy only the header from the first workbook into the output workbook
- Loop through all files in the input folder to build the output workbook
The macro is in a standalone file so no need to copy a macro into another workbook.
- Copy a single (specified) sheet from each workbook into a single workbook
-
This looks very similar to the following article:
-
Maybe try something like:
Code- Function ExtractText(sInput As String) As String
- Dim sArray() As String
- sArray = Split(sInput, "/")
- ExtractText = sArray(UBound(sArray))
- sArray = Split(ExtractText, ".")
- ExtractText = sArray(LBound(sArray))
- End Function
- Sub Test()
- Dim sText As String
- sText = ExtractText(Sheet1.Range("A1"))
- Sheet1.Range("B1").Value = sText
- End Sub
This assumes of course that the filename you are trying to extract before the ".bmp" extension does not contain any other full stops eg, CBend.0.bmp would only return the CBend value.
-
It looks like you have misspelled 'Address' in the Target property name. Also make sure the underscore character is at the end of each line.
Try :Code- MsgBox " Check to verify Veteran data is entered in FY ## Referrals." & vbCr & _
- " It's critical that carryover data is captured. " & vbCr & _
- " Please enter the Name in the walk in list if not on either last year's or this year's consult's list! " & vbCr & _
- " You have entered a name in cell " & Target.Address, vbInformation, "Vocational Services - OVR " & ActiveSheet.Name
-