Posts by jaslake

jaslake · Sep 20th 2017

Re: Accessing Values from Names Manager

Hi Mackeral...

Perhaps

Quote

TS = Range("Name_to_Lookup").Value

jaslake · Aug 25th 2017

Re: Help needed to modify the following code so that the data is copied only once.

Hi raghuprabhu

Welcome to the Forum!!

Replace your LoopThroughDirectory Code with this...

Code

Sub LoopThroughDirectory()
Dim MyFile As String
Dim eRow As Long
Dim tgtWb As Workbook
Dim tgtWs As Worksheet
Dim srcWb As Workbook
Dim srcWs As Worksheet
Dim LR As Long
Dim FilePath As String
FilePath = ThisWorkbook.Path & "\"
' Debug.Print FilePath
Set tgtWb = ThisWorkbook
Set tgtWs = tgtWb.Sheets("Sheet1")
MyFile = Dir(FilePath)
' Debug.Print MyFile
Application.ScreenUpdating = False
Do While Len(MyFile) > 0
If MyFile = "zMaster.xlsm" Then
Exit Sub
End If
Set srcWb = Workbooks.Open(FilePath & MyFile)
Set srcWs = srcWb.Sheets("Sheet1")
With srcWs
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Not .AutoFilterMode Then
.Rows("1:1").AutoFilter
End If
.Range("A1:E" & LR).AutoFilter Field:=5, Criteria1:="="
If Not .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 = 0 Then
.Range("A2:D" & LR).SpecialCells(xlCellTypeVisible).Copy
eRow = tgtWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
tgtWs.Cells(eRow, "A").PasteSpecial
.Range(.Cells(2, 5), .Cells(LR, 5)).SpecialCells(xlCellTypeVisible).Value = "Yes"
Else
.AutoFilterMode = False
End If
Application.DisplayAlerts = False
srcWb.Close True
Application.DisplayAlerts = True
MyFile = Dir
End With
Loop
tgtWb.Save
Application.ScreenUpdating = True
End Sub

Display More

jaslake · Jun 4th 2017

Re: Accumulate count of Combobox selections

Hi zey67

List Boxes can be Multi Select...however, I don't see how that fills your need...

jaslake · Jun 1st 2017

Re: Accumulate count of Combobox selections

Hi zey67

Far as I know you cannot have multiple selections in your Combo Boxes.

jaslake · May 31st 2017

Re: Accumulate count of Combobox selections

Hi zey67

All of your 10 Combo Boxes are linked to the same Cell (M1) and, accordingly, will assume that value...

jaslake · Mar 22nd 2017

Re: Format TextBox for percentage

Hi Willanss1988

Perhaps like this...

Code

TextBox50 = Format(Sheet3.Range("P2").Value, "0.00%")

jaslake · Mar 17th 2017

Re: help with send an Email with Excel VBA Code

Hi pacedove

Welcome to the Forum!!!

Try this Code...

Code

Sub sendmail()
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim Signature As String
Dim ws As Worksheet
Dim cel As Range
Dim LR As Long
Set ws = Sheets("MRM")
With ws
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Not .AutoFilterMode Then
.Range("A3:P3").AutoFilter
End If
.Range("A3:P" & LR).AutoFilter Field:=16, Criteria1:="<>"
If .Range("P3:P" & LR).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
For Each cel In .Range("P4:P" & LR).SpecialCells(xlCellTypeVisible)
EmailTo = .Cells(cel.Row, "J").Value
CCto = .Cells(cel.Row, "K").Value
Subj = .Cells(cel.Row, "L").Value
Filepath = .Cells(cel.Row, "M").Value
msg = .Cells(cel.Row, "N").Value
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & _
"\Microsoft\Signatures\mrm.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = EmailTo
.CC = CCto
.BCC = ""
.Subject = Subj
.HTMLBody = msg & "<br>" & Signature
'.body = msg & vbNewLine & vbNewLine & Signature
' .Attachments.Add Filepath 'Uncomment this Line if you've added attachments
.Display '.Send 'or use .Display
End With
Next cel
End If
.AutoFilterMode = False
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Display More

jaslake · Mar 2nd 2017

Re: VBA to delete entire row if cell matches the exact whole word

Hi CodeNerd

Please include your existing Code in your Sample File. Please make sure the Structure of your Sample File is of the same Structure as your Actual File. Please include a Worksheet that demonstrates your expected results.

jaslake · Mar 1st 2017

Re: VBA to delete entire row if cell matches the exact whole word

Well, you could change xlPart to xlWhole...a Sample File would be good so we can help you debug.

jaslake · Mar 1st 2017

Re: VBA to delete entire row if cell matches the exact whole word

Hi CodeNerd

Perhaps remove the Wildcard from in front of *test* becoming test*

jaslake · Feb 28th 2017

Re: Delete entire row if a cell does not match the keyword/data

Hi Jomz07

Yes, this is correct...

Quote

if I change Field:=6 to, let's say 3, would that be filtering column 3?

However, if your Filter Range reads like this Column C would be 2...

Code

.Range("$B$2:$JH" & LR).AutoFilter Field:=2

Further, if it reads like this Column C would be 1...

Code

.Range("$C$2:$C" & LR).AutoFilter Field:=1

jaslake · Feb 24th 2017

Re: find rows and replace each with several rows

You're welcome...glad I could help.

jaslake · Feb 24th 2017

Re: Delete entire row if a cell does not match the keyword/data

Hi Jomz07

Sory for the delayed response...didn't get Email Notification.

Yes, this Line of Code says to Filter Column 6 (F)...

Code

.Range("$A$2:$JH" & LR).AutoFilter Field:=6, Criteria1:= _
"<>USI - GSC - L1", Operator:=xlAnd

jaslake · Feb 24th 2017

Re: find rows and replace each with several rows

Hi catcat111

As I understand your requirements, this Code in the attached appears to do as you suggested...let me know...

Code

Option Explicit
Sub UpdateRecords()
Dim ws As Worksheet
Dim LR As Long
Dim lLoop As Long
Dim rFoundCell As Range
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1")
With ws
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
With .Range(.Cells(7, 1), .Cells(LR, 1))
Set rFoundCell = .Cells(1, 1)
For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "date")
Set rFoundCell = .Find(What:="date", After:=rFoundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
ws.Range("A1:H5").Copy
.Cells(rFoundCell.Row - 6, "A").Insert Shift:=xlDown
Next lLoop
End With
.AutoFilterMode = False
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
.Range("A1:A" & LR).AutoFilter Field:=1, Criteria1:="date"
.Range("A6:A" & LR).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Display More

jaslake · Feb 8th 2017

Re: Delete entire row if a cell does not match the keyword/data

Hi Jomz07

Welcome to the Forum!!!

Try this Code in a General Module...

Code

Option Explicit
Sub Delete_Me()
Dim ws As Worksheet
Dim LR As Long
Set ws = Sheet1
With ws
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Not .AutoFilterMode Then
.Rows("2:2").AutoFilter
End If
.Range("$A$2:$JH" & LR).AutoFilter Field:=6, Criteria1:= _
"<>USI - GSC - L1", Operator:=xlAnd
Application.DisplayAlerts = False
.UsedRange.Offset(2, 0).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
.AutoFilterMode = False
End With
End Sub

Display More

jaslake · Jan 14th 2017

Re: Find Key Word in Col A, Select Content, Paste Consecutively on Newly Added Sheet

Hi Chris

Tis really straightforward...rEndCell.Row - 2 Rows

Code

rEndCell.Row - 2

Likewise, find the Last Row +2 Rows

Code

wsTgtLR = wsTGT.Range("A" & Rows.Count).End(xlUp).Row + 2

jaslake · Jan 14th 2017

Re: Find Key Word in Col A, Select Content, Paste Consecutively on Newly Added Sheet

Hi Chris

There is no closing "TABLE" line on this "DOC" record...why? This is the cause of the failure...it's not consistent...

Excel 2007 32 bit
[TABLE="class: head"]
[TR="bgcolor: #888888"]
[TH][/TH]
[TH]

A

[/TH]
[TH]

B

[/TH]
[TH]

C

[/TH]
[TH]

D

[/TH]
[TH]

E

[/TH]
[TH]

F

[/TH]
[TH]

G

[/TH]
[TH]

H

[/TH]
[TH]

I

[/TH]
[TH]

J

[/TH]
[TH]

K

[/TH]
[TH]

L

[/TH]
[TH]

M

[/TH]
[TH]

N

[/TH]
[TH]

O

[/TH]
[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

336

[/TD]

[td]

DOC

[/td]

[td]

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[td]

PUBLIC

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

337

[/TD]

[td]

ID

[/td]

[td]

SUF

[/td]

[td]

TIV-11

[/td]

[td]

TIV-12

[/td]

[td]

TIV-13

[/td]

[td]

TIV-14

[/td]

[td]

TIV-15

[/td]

[td]

TIV-16

[/td]

[td]

TIV-17

[/td]

[td]

TIV-18

[/td]

[td]

TIV-19

[/td]

[td]

TIV-22

[/td]

[td]

TIV-24

[/td]

[td]

TIV-25

[/td]

[td]

TIV-26

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

338

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

F

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

339

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

G

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

340

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

P

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

341

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

J

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

342

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

J

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

343

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

J

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

344

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

J

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

345

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

J

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

346

[/TD]

[td]

H42K-BBR-004

[/td]

[td]

J

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[td]

Yes

[/td]

[td]

[/td]

[td]

Yes

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

347

[/TD]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

348

[/TD]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

349

[/TD]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

350

[/TD]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[/TR]
[TR="bgcolor: #FFFFFF"]
[TD="bgcolor: #888888"]

351

[/TD]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[td]

[/td]

[/TR]
[/TABLE]
[TABLE="class: grid"]

[tr]

[td]

Sheet: Sheet1

[/td]

[/tr]

[/TABLE]

jaslake · Jan 14th 2017

Re: Find Key Word in Col A, Select Content, Paste Consecutively on Newly Added Sheet

Something is different. I'll look at it in the AM.

jaslake · Jan 13th 2017

Re: Find Key Word in Col A, Select Content, Paste Consecutively on Newly Added Sheet

Hi Chris

Here's the Annotated Code...something makes no sense let me know...

Code

Option Explicit
Sub MoveRecords()
Dim wsSRC As Worksheet
Dim wsTGT As Worksheet
Dim lStart As Long
Dim rStartCell As Range
Dim rEndCell As Range
Dim LC As Long
Dim wsSrcLR As Long
Dim wsTgtLR As Long
Set wsSRC = Sheets("Sheet1") 'Raw Data
Set wsTGT = Sheets("Sheet2") 'Output Data
Application.ScreenUpdating = False
With wsTGT
.Cells.Clear 'Clear the Output Data
wsTgtLR = 2 'Set the Start Row
End With
With wsSRC 'With Raw Data Sheet
'Find the Last Column Number
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
'Find the Last used Row in Column A
wsSrcLR = .Range("A" & .Rows.Count).End(xlUp).Row
'Where do we start looking for "DOC"?
Set rStartCell = .Cells(1, 1)
'Count the number of incidents of "DOC" and cycle through them
For lStart = 1 To WorksheetFunction.CountIf(.Cells, "DOC")
'Find "DOC"...that's our Starting Row
Set rStartCell = .Columns(1).Find(What:="DOC", After:=rStartCell, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
MsgBox "Found DOC at Row " & rStartCell.Row '<---Can be Deleted
'From that ROW of "DOC" find the first incident of "TABLE*" (with Wildcard)
Set rEndCell = .Range(.Cells(rStartCell.Row, "A"), .Cells(wsSrcLR, "A")) _
.Find("TABLE*", , xlValues, xlPart, xlByRows, xlNext, False)
MsgBox "Found TABLE at Row " & rEndCell.Row '<---Can be Deleted
'Copy that Range of Cells
.Range(.Cells(rStartCell.Row, "A"), .Cells(rEndCell.Row - 2, LC)).Copy
'Paste that Range of Cells to the Target Worksheet @ Range A and the Last Row
wsTGT.Range("A" & wsTgtLR).PasteSpecial (xlPasteValues)
'Find the New Last Row in the Target Worksheet
wsTgtLR = wsTGT.Range("A" & Rows.Count).End(xlUp).Row + 2
'Look for the Next incident of "DOC"
Next lStart
End With
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub

Display More

jaslake · Jan 13th 2017

Re: Find Key Word in Col A, Select Content, Paste Consecutively on Newly Added Sheet

Hi Chris

Glad you like it...thanks for the Rep.

I'll comment the Code and repost it. With regard to the Columns and mixed Content, how many unique "TIV" numbers are there and what are they?