Possibly...
Posts by dangelor
-
-
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
-
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
-
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
-
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
-
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
-
Glad to hear! You're welcome!
-
-
-
-
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
-
-
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
-
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.
Better would to just use the column's number...
-
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.
-
It is stopped near 2090 cell...in total I have 65k cells in the A column
What stopped? Did the macro finish running?
-
-
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
-
...and the error is???
-
What error and on which line of code?