Posts by dangelor

dangelor · Jan 6th 2021

Try...

Code

Private Sub CommandButton2_Click()
Dim ws As Worksheet, lastrow As Long
Dim v As Variant
Worksheets("SheetJS").Range("C43:C543").Copy
Set ws = Workbooks.Open(Filename:=Environ("userprofile") & "\Desktop\output.xlsx").Sheets("Main")
With ws
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(lastrow + 1, 1).PasteSpecial xlPasteValues
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1:A" & lastrow) = .Range("A1:A" & lastrow).Value2
.Range("A1:A" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Display More

dangelor · Jan 6th 2021

Possibly...

Code

Option Explicit
Private Sub CommandButton2_Click()
Dim ws As Worksheet, lastrow As Long
Worksheets("SheetJS").Range("C43:C543").Copy
Set ws = Workbooks.Open(Filename:="blahblah\output.xlsx").Sheets("Main")
With ws
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(lastrow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1:A" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Display More

dangelor · Jan 6th 2021

Possibly...

Code

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim f As Object, sPath As String, sFileName As String
If SaveAsUI = False Then
Cancel = True
sFileName = Worksheets("PR Form").Range("W2").Value2 & ".xlsm"
Set f = Application.FileDialog(msoFileDialogFolderPicker)
With f
.InitialFileName = "C:"
If .Show = True Then
sPath = .SelectedItems(1)
End If
End With
If sPath <> vbNullString Then
Application.EnableEvents = False
ActiveWorkbook.SaveAs Filename:=sPath & Application.PathSeparator & sFileName, FileFormat:=52
Application.EnableEvents = True
Else
MsgBox "Action cancelled.", vbInformation + vbOKOnly, "No Path Selected"
Cancel = True
End If
End If
End Sub

Display More

dangelor · Dec 24th 2020

Possibly...

Code

Dim OUTAPP As Object
Dim sFileName As String, i As Long, msg As Long
Call ws_settings
Set OUTAPP = CreateObject("OUTLOOK.APPLICATION")
For i = 3 To ws6.Cells(Rows.Count, 1).End(xlUp).Row
msg = 0
If ws6.Cells(i, 11) <> "" Then
sFileName = ws6.Cells(i, 12)
If sFileName = "" Then
msg = MsgBox("There was no attachment file listed for the email to " _
& ws6.Cells(i, 11) & "." & vbCrLf & "Do you wish to continue?", _
vbQuestion + vbYesNo, "No Attachment Specified")
If msg = vbNo Then GoTo nexti
End If
If Dir(sFileName, vbNormal) = "" Then
msg = MsgBox("The attachment file listed for the email to " _
& ws6.Cells(i, 11) & "does not exist." & vbCrLf & "Do you wish to continue?", _
vbQuestion + vbYesNo, "Attachment Missing")
If msg = vbNo Then GoTo nexti
End If
With OUTAPP.createitem(0)
.To = ws6.Cells(i, 11).Value
.Subject = "Insurance Policy Renewal Reminder"
.body = ws6.Cells(i, 15).Value
If msg = 0 Then .attachments.Add sFileName
.Save
End With
End If
nexti:
Next i
Set OUTAPP = Nothing

Display More

dangelor · Dec 24th 2020

Possibly...

Code

Sub SearchDB()
Dim v As Variant, n As Variant
Dim i As Long, j As Long
With ThisWorkbook
v = .Worksheets("Database").UsedRange.Resize(, 9)
n = .Worksheets("New").UsedRange
For i = LBound(v) To UBound(v)
For j = LBound(n) To UBound(n)
If v(i, 2) = n(j, 2) Then 'first name
If v(i, 3) = n(j, 3) Then 'last name
If v(i, 7) = n(j, 7) Then 'mobile
If v(i, 8) = n(j, 8) Then 'email
'puts the matching new serial number to col I of the database
v(i, 9) = n(j, 1)
End If
End If
End If
End If
Next j
Next i
.Worksheets("Database").UsedRange.Resize(, 9) = v
End With
End Sub

Display More

dangelor · Dec 24th 2020

Glad to hear! You're welcome!

dangelor · Dec 24th 2020

Possibly...

Code

Sub test()
Dim v As Variant, i As Long
'Change workbook and worksheet as needed
With ThisWorkbook.Worksheets("Sheet1").UsedRange
v = .Columns(1)
For i = LBound(v) To UBound(v)
If IsError(v(i, 1)) Then v(i, 1) = v(i - 1, 1)
Next i
.Columns(1) = v
End With
End Sub

Display More

dangelor · Dec 15th 2020

If you're only copying one row, why are you autofilling 1,500 rows with formulas?

dangelor · Dec 14th 2020

Did the code crash Excel?

dangelor · Dec 14th 2020

Possibly...

Code

Option Explicit
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 Not_Tested()
Dim StartTime As Double
Dim v As Variant, f As Variant
Dim i As Long, lRow As Long, ws As Worksheet
Const sPATH As String = "c:\vba"
Const sEXT As String = "csv"
StartTime = Timer
Application.ScreenUpdating = False
Set ws = Workbooks("MasterFile - Copy.xlsm").Worksheets("MasterSheet")
ws.Cells.Clear
v = GetFiles(sPATH, sEXT)
For Each f In v
With Workbooks.Open(f).Worksheets(1)
.Range("I1").Value = "V/SMA10"
.Columns("I:I").NumberFormat = "General"
.Range("I2").FormulaR1C1 = "=AVERAGE(RC[-1]:R[9]C[-1])"
.Range("I2").AutoFill Destination:=Range("I2:I1500")
.Range("J1").Value = "Vol/Change%"
.Columns("J:J").NumberFormat = "0.00%"
.Range("J2").FormulaR1C1 = "=(RC[-2]-RC[-1])/RC[-1]"
.Range("J2").AutoFill Destination:=Range("J2:J1500")
.Range("K1").Value = "SMA10"
.Columns("K:K").NumberFormat = "0.00$"
.Range("K2").FormulaR1C1 = "=AVERAGE(RC[-4]:R[9]C[-4])"
.Range("K2").AutoFill Destination:=Range("K2:K1500")
.Range("L1").Value = "SMA30"
.Columns("L:L").NumberFormat = "0.00$"
.Range("L2").FormulaR1C1 = "=AVERAGE(RC[-5]:R[29]C[-5])"
.Range("L2").AutoFill Destination:=Range("L2:L1500")
.Range("M1").Value = "BUY/SELL SMA10 CROSSOVER"
.Range("M2").FormulaR1C1 = "=IF(AND(RC[-2]>RC[-1],R[1]C[-2]<R[1]C[-1],RC[-1]>R[1]C[-1]),""BUY"",IF(AND(RC[-7]<RC[-4],R[1]C[-7]>R[1]C[-4]),""SELL"",""""))"
.Range("M2").AutoFill Destination:=Range("M2:M120")
.Range("O1").Value = "Close/Change%"
.Columns("O:O").NumberFormat = "0.00%"
.Range("O2").FormulaR1C1 = "=(RC[-8]-R[1]C[-8])/R[1]C[-8]"
.Range("O2").AutoFill Destination:=Range("O2:O1500")
.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
Application.CutCopyMode = False
End With
End If
Next
ws.Columns.AutoFit
.Parent.Close True
End With
Next f
With Application
.ScreenUpdating = True
End With
MsgBox "This code ran successfully in " & Round(Timer - StartTime, 2) & " seconds", vbInformation
End Sub

Display More

dangelor · Dec 12th 2020

Try changing this

Code

q = Me.cbChooseGroup.ListIndex

to this

Code

q = Me.cbChooseGroup.Value

dangelor · Dec 11th 2020

Possibly...

Code

Option Explicit
Sub Not_Tested()
Dim myPath As String, myFP As String
Dim rg As Range, v As Variant, i As Long
With ThisWorkbook.Sheets("Settings")
myPath = .Range("B1").Value
myFP = .Range("B2").Value
End With
With Workbooks.Open(Filename:=myFP, UpdateLinks:=False).Sheets("Sheet1") '''CHANGE SHEET NAME AS NEEDED'''
Set rg = .Cells(1, 1).CurrentRegion
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1)
v = rg
End With
For i = LBound(v) To UBound(v)
If Len(v(i, 1)) > 0 And Len(v(i, 3)) > 0 Then
Name myPath & v(i, 1) As myFP & v(i, 3)
End If
Next i
End Sub

Display More

dangelor · Dec 11th 2020

I assume that TglOrderMasuk and the others are single cell named ranges of the column headers. If so, to use them you need to extract the range's column to use it in the format you have shown.

Code

With Worksheets("ListItem")
n = .Cells(Rows.Count, .Range("TglOrderMasuk").Column).End(xlUp).Row + 1
.Cells(n, .Range("TglOrderMasuk").columnn).Value = txbOrderMasuk.Value
'...
'... and so on.
End With

Better would to just use the column's number...

Code

With Worksheets("ListItem")
n = .Cells(Rows.Count, 2).End(xlUp).Row + 1
.Cells(n, 2).Value = txbOrderMasuk.Value
'...
'... and so on.
End With

dangelor · Dec 10th 2020

Can't tell the players without a scorecard... As Mumps said earlier, post your workbook and code.

I ran the code on a test file of over 600K rows and 1 column. No problems. Run time was less than 3 seconds.

dangelor · Dec 10th 2020

Quote from SUBHASHn

It is stopped near 2090 cell...in total I have 65k cells in the A column

What stopped? Did the macro finish running?

dangelor · Dec 10th 2020

Code

Workbooks("C:\BP\Input.xlsx").Save

dangelor · Dec 10th 2020

Try this version...

Code

Sub Rename_v5()
Dim lRow As Long, rg As Range
Dim v As Variant, k As Variant
Dim i As Long, j As Long, x As Long
Application.ScreenUpdating = False
With Workbooks.Open(Filename:="C:\BP\Input.xlsx").Worksheets("Sheet1") '''Change worksheet name as needed'''
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rg = .Range("a2:a" & lRow)
End With
v = Application.Transpose(rg)
With CreateObject("Scripting.Dictionary")
For Each k In v
.Item(k) = Empty
Next k
k = .keys
End With
v = rg.Resize(, 2)
For i = LBound(k) To UBound(k)
x = 0
For j = LBound(v) To UBound(v)
If k(i) = v(j, 1) Then
x = x + 1
If x > 1 Then
v(j, 2) = Replace(k(i), ".", "_" & x - 1 & ".")
Else
v(j, 2) = k(i)
End If
End If
Next j
Next i
rg.Resize(, 2) = v
Application.ScreenUpdating = True
End Sub

Display More

dangelor · Dec 10th 2020

...and the error is???

dangelor · Dec 10th 2020

What error and on which line of code?

dangelor · Dec 10th 2020

Possibly...

Code

vRws = Filter(Application.Transpose(Evaluate(Replace(Replace("if(#= & r ,row(#)-~,""X"")", "#", .Columns(37).Address), "~", .Rows(0).Row))), "X", False)

Posts by dangelor

VBA Copy Paste deletes first row after filter blanks

VBA Copy Paste deletes first row after filter blanks

VBA to force save excel document as macro-enabled & auto populating filename as reference in a cell

outlook mail attachment

Macro to find duplicates based on more than one column

Change #VALUE! fields in a column

Change #VALUE! fields in a column

Routine loops through files in folder, progressively slows down resulting in workbook crash.

Routine loops through files in folder, progressively slows down resulting in workbook crash.

Routine loops through files in folder, progressively slows down resulting in workbook crash.

Searching table column for a value and populating an array with the matching row contents

Macro to rename files in a foder

I just start to learn VBA, please help me to fix this error

Renaming duplicate column names

Renaming duplicate column names

Renaming duplicate column names

Renaming duplicate column names

Renaming duplicate column names

Renaming duplicate column names

Searching table column for a value and populating an array with the matching row contents