Posts by dangelor
-
-
Third time's the charm...?
Code
Display MoreSub test_v3() Dim d1 As Date, d2 As Date Dim rg As Range, i As Long Dim c As Range, a As Long Dim s As String With Sheet1 Set rg = .Range("A8:C11") d1 = Cells(2, 2).Value d2 = Cells(3, 2).Value .Cells(3, 6).CurrentRegion.Offset(1).ClearContents For i = 4 To d2 - d1 + 4 .Cells(i, 6) = i + d1 - 4 .Cells(i, 7) = Choose(Weekday(.Cells(i, 6)), "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") Next i For i = 4 To d2 - d1 + 4 a = 0 Set c = rg.Find(.Cells(i, 7).Value) If Not c Is Nothing Then s = c.Address Do DoEvents If a = 0 Then .Cells(i, 8) = c.Offset(0, 1).Value .Cells(i, 9) = c.Offset(0, -1).Value a = a + 1 Else .Cells(i, 6).Resize(, 4).Copy .Cells(i, 6).Resize(, 4).Insert shift:=xlDown a = a + 1 i = i + 1 End If Set c = rg.FindNext(c) Loop While s <> c.Address End If Next i Set rg = .Cells(3, 6).CurrentRegion For i = rg.Rows.Count To 1 Step -1 If rg.Cells(i, 3) = "" Then rg.Rows(i).Delete Next i End With End Sub
-
Could you just change the product set to "Set 1, Set 2"?
-
Possibly...
Code
Display MoreSub SendMail() Dim olApp As Object Dim olMail As Object Dim olInsp As Object Dim wdDoc As Object Dim oRng As Object Dim sPath As String Dim sMessage As String Dim sFile As String Dim cell As Range Dim sBCC As String sMessage = "<br>" & "<font size=""3"" face=""Cambria"" color=""Blue"">" & "Dear Valuable Customer, <br><br>" _ & "Greetings!! </b><br><br>" _ & " On behalf of everyone from " & "<b> SCHWING STETTER INDIA PVT LTD,</b>" & " We would like to thank you for being a Customer/A Guest/An Investor.<br><br>" _ & " We value the trust you have put In our products, services and would like to thank you for that. It is always a pleasure serving you and we certainly look forward to doing that in the future.<br><br>" _ & " And We are happy to inform that we have designed a new catalogue of" & "<b> SCHWING STETTER </b>" & "products for the convenience of the customers to know about the products in detail for your requirement.<br><br>" _ & " Kindly find the " & "<b> SCHWING STETTER PRODUCT CATALOGUE.</b>" & "<br><br>" _ & " Your feedback is very important as we are constantly looking for ways to improve our services and products.<br><br>" _ & " Stay Safe! Stay Healthy!!<br><br>" _ sPath = Environ("USERPROFILE") & "\Desktop\Schwing product catalogue\" Set olApp = CreateObject("Outlook.Application") 'create BCC list For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants) If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "J").Value) = "" Then sBCC = sBCC & ";" & cell.Value cell.Offset(, 1).Value = "Mail sent on " & Format(Date, "mm/dd/yy") End If Next cell On Error Resume Next Set olMail = olApp.CreateItem(0) With olMail .BCC = sBCC .Subject = "GREETINGS FROM SCHWING STETTER!!!" .HTMLBody = sMessage Set olInsp = .GetInspector Set wdDoc = olInsp.WordEditor 'access the message body for editing .Display 'required to edit message body sFile = Dir$(sPath & "*.pdf") While sFile <> "" .Attachments.Add sPath & sFile sFile = Dir$() Wend End With Set olApp = Nothing Set olMail = Nothing Set olInsp = Nothing Set wdDoc = Nothing Set oRng = Nothing End Sub
-
Try this version...
Code
Display MoreSub test_v2() Dim d1 As Date, d2 As Date Dim rg As Range, i As Long Dim c As Range With Sheet1 Set rg = .Range("A8:C11") d1 = Cells(2, 2).Value d2 = Cells(3, 2).Value .Cells(3, 6).CurrentRegion.Offset(1).ClearContents For i = 4 To d2 - d1 + 4 .Cells(i, 6) = i + d1 - 4 .Cells(i, 7) = Choose(Weekday(.Cells(i, 6)), "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") Next i For i = 4 To d2 - d1 + 4 Set c = rg.Find(.Cells(i, 7).Value) If Not c Is Nothing Then .Cells(i, 8) = c.Offset(0, 1).Value .Cells(i, 9) = c.Offset(0, -1).Value End If Next i Set rg = .Cells(3, 6).CurrentRegion For i = rg.Rows.Count To 1 Step -1 If rg.Cells(i, 3) = "" Then rg.Rows(i).Delete Next i End With End Sub
-
Possibly...
Code
Display MoreSub test() Dim d1 As Date, d2 As Date Dim rg As Range, i As Long With Sheet1 Set rg = .Range("A8:C11") d1 = Cells(2, 2).Value d2 = Cells(3, 2).Value .Cells(3, 6).CurrentRegion.Offset(1).ClearContents For i = 4 To d2 - d1 + 4 .Cells(i, 6) = i + d1 - 4 If Weekday(.Cells(i, 6)) = 7 Then .Cells(i, 6).Resize(, 4).Copy .Cells(i, 6).Resize(, 4).Insert shift:=xlDown rg.Copy .Cells(i, 7) End If Next i Set rg = .Cells(3, 6).CurrentRegion For i = rg.Rows.Count To 1 Step -1 If rg.Cells(i, 2) = "" Then rg.Rows(i).Delete Next i End With End Sub
-
Possibly...
Code
Display MoreSub PrintPageNumbers() Dim vpb As VPageBreak, hpb As HPageBreak Dim vp As Long, hp As Long Dim v As Variant, p As Long ActiveWindow.View = xlPageBreakPreview With ActiveSheet v = .UsedRange .ResetAllPageBreaks For Each vpb In .VPageBreaks For Each hpb In .HPageBreaks hp = hpb.Location.Row vp = vpb.Location.Column p = p + 1 v(hp - 1, vp - 1) = "Page " & p Next hpb If hp - 1 < UBound(v, 1) Then p = p + 1 v(UBound(v, 1), vp - 1) = "Page " & p End If Next vpb If vp - 1 < UBound(v, 2) Then For Each hpb In .HPageBreaks hp = hpb.Location.Row vp = UBound(v, 2) p = p + 1 v(hp - 1, vp) = "Page " & p Next hpb If hp - 1 < UBound(v, 1) Then p = p + 1 v(UBound(v, 1), vp) = "Page " & p End If End If .UsedRange = v End With ActiveWindow.View = xlNormalView End Sub
-
Not exactly sure what you're asking...
...Is it possible for combobox selections to be removed or hidden from the following comboboxes?...
If you mean removing duplicate items in your combo boxes, try this...
Code
Display MorePrivate Sub UserForm_Initialize() Dim e As Variant, arr As Variant Set xRange = WWorksheets("Engine").Range("ListPlaster") 'create an array of unique items in column 1 With CreateObject("Scripting.Dictionary") For Each e In Application.Index(xRange.Columns(1).Value, 0, 0) .Item(e) = Empty Next e arr = .keys End With Me.ComboBox1.List = arr ... Me.ComboBox15.List = arr End Sub
-
-
-
...but the looping method Works but it took four times ( 25 minutes ) than my previous method...
This should be faster
Code
Display MoreDim u, v, i As Long, j As Long With Worksheets("Readings") lastrow4 = .Cells(Rows.Count, "AG").End(xlUp).Row v = .Range("AF2:AG" & lastrow4).Value End With With Scorecard.Worksheets("Visit List") lastrow4 = .Cells(Rows.Count, "AH").End(xlUp).Row .Range("AG2:AH" & lastrow).Value = "Not Tagged" u = .Range("AG2:AH" & lastrow).Value For i = LBound(u) To UBound(u) For j = LBound(v) To UBound(v) If u(i, 1) = v(j, 2) Then u(i, 2) = "Tagged" Next j Next i .Range("AG2:AH" & lastrow).Value = u End With
-
Possibly using a for loop...
CodeWith Scorecard.Worksheets("Visit List") lastrow4 = .Cells(Rows.Count, 34).End(xlUp).Row For i = 2 To lastrow4 If IsError(WorksheetFunction.VLookup(.Range("AG" & i), Worksheets("Readings").Columns("AF:AG"), 2, 0)) Then .Range("AH" & i).value = "Not tagged" Else .Range("AH" & i).value = "Tagged" End If Next i End With
-
-
-
-
-
Possibly...
Code
Display MoreSub Combine() Dim rg As Range, c As Range Dim d As Range, e As Range Dim i As Long With Worksheets("Results") .UsedRange.ClearContents Set rg = Worksheets("Master Schedule").Cells(1, 1).CurrentRegion rg.Columns(1).Copy .Cells(1, 1) .Columns(1).RemoveDuplicates Columns:=Array(1), Header:=xlYes rg.Rows(1).Copy .Cells(1, 1) Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1) rg.Columns(2).Copy .Cells(1, 99) .Cells(1, 99).CurrentRegion.RemoveDuplicates Columns:=Array(1), Header:=xlNo .Cells(1, 99).CurrentRegion.Copy .Cells(1, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True .Columns(99).Delete End With With Worksheets("Time Rate").UsedRange For i = 1 To rg.Rows.Count Set c = .Columns(1).Find(rg.Cells(i, 1).Value) If Not c Is Nothing Then Set d = Worksheets("Results").UsedRange.Find(rg.Cells(i, 1).Value) Set e = Worksheets("Results").UsedRange.Find(rg.Cells(i, 2).Value) d.Offset(, e.Column - 1) = rg.Cells(i, 1).Offset(, 2).Value * c.Offset(, 3).Value + c.Offset(, 2).Value End If Next i End With End Sub
-
-
Would take a while to run but possibly...
-