ExcelBanter - Select rows that are 'blinking'

ExcelBanter (https://www.excelbanter.com/)

- Excel Programming (https://www.excelbanter.com/excel-programming/)

- - Select rows that are 'blinking' (https://www.excelbanter.com/excel-programming/452840-select-rows-blinking.html)

Select rows that are 'blinking'

Hello,

Small question :).

As part of a module some field/records are 'selected' and they are 'blinking' (flashing) because they are not realy selected as when you select row(s) on the left site when you select complete rows with your mouse.

Info: Those 'blinking' records stopped blinking when you push the escape button or using the macro 'application.CutCopyMode=False'.

I like to get the solution that the rows of those 'blinking' ones gonna selected as a real active selected row(s).

Should be simple,..... but cant find the solution so quick :(.

regards,
Johan

Select rows that are 'blinking'

Sub CopyRows()

Dim srcbk As Workbook, srcsht As Worksheet, cel As Range

Dim tgtbk As Workbook, flag As Boolean, L0, L1, wrk As String
ReDim working(0) As String

Set srcbk = ActiveWorkbook
Set srcsht = ActiveSheet
'Find the data.

working(0) = "A" & ActiveCell.Row

For Each cel In Selection.Cells
For L0 = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
'Case-sensitive.
If Cells(L0, 1).Value = Cells(cel.Row, 1).Value Then

flag = False
For L1 = 0 To UBound(working)
If working(L1) = "A" & L0 Then flag = True
Next
If Not flag Then
ReDim Preserve working(UBound(working) + 1)
working(UBound(working)) = "A" & L0
End If
End If
Next
Next

'This assumes that the workbook is entered as a string value
'(e.g. literally "C:\Apps\File1.xls"), not an Excel reference.
On Error Resume Next

Set tgtbk = Workbooks.Open(Sheets("Sheets1").Range("F2").Value ) 'Location of File1

On Error GoTo 0
If Not (tgtbk Is Nothing) Then
tgtbk.Activate

'Out with the old and in with the new.
Range("A2:A" & _
Cells.SpecialCells(xlCellTypeLastCell).Row).Entire Row.Delete

wrk = Join$(working, ",")
srcsht.Range(wrk).EntireRow.Copy

Range("A2").Select
ActiveSheet.Paste
tgtbk.Save
tgtbk.Close

'Kolom X bevat de Sdl Upload datum

srcsht.Range(wrk).EntireRow.Copy

For Each cel In Range(Replace$(wrk, "A", "X")).Cells

'cel.Value = Date
cel.Value = DateValue(Now) & " / " & TimeValue(Now)
Next
End If

Set cel = Nothing
Set srcsht = Nothing
Set tgtbk = Nothing
Set srcbk = Nothing

'NOW THE MACRO COMES BACK IN THE SHEET WERE IT BEFORE COPIEED THE SELECTED ROWS FROM TO THE OTHER FILE.
'THE ROWS THAT ARE SELECTED ARE BLINKING/FLASHING BU NOT REALLY SELECTED FOR A FURTHER ACTION.
'I NEED TO SELECT THOSE ROWS AS REAL SELECTED AS WHEN YOU SELECT WHOLE ROWS ON THE LEFT HEADINGS.
'NOW I WANT TO RUN THE NEXT MODULE I GET FROM CLAUS, BUT THAT NEEDS SELECTED ROWS :)

End Sub

Sub GetMessage()
Dim rngC As Range
Dim varEmpty() As Variant
Dim n As Long, i As Long
Dim myStr As String

For Each rngC In Intersect(Range("L:L"), Selection)
If Len(rngC) = 0 Then
i = i + 1
ReDim Preserve varEmpty(n)
varEmpty(n) = rngC.Address(0, 0)
n = n + 1
End If
Next
Select Case i
Case 0
Exit Sub
Case 1
myStr = varEmpty(0)
Case Else
myStr = Join(varEmpty, Chr(10))
End Select

MsgBox "Incomplete data in column K." & vbNewLine & "." & vbNewLine & "Ttl empty records = " & i & " st." & vbNewLine & "That are the records" & Chr(10) & myStr & vbNewLine & "." & vbNewLine & "Solve those !." & vbNewLine & "."

End Sub

Select rows that are 'blinking'

Oke, some explanation.

The first module;
1) Active field is on or more cells. Those could be selected by the user in a range, but it could be also separated selected fields with the CTRL option.
2) The module looks for those active cells in column A and select all rows that have the same data in column A as the active cells in column A (info; Column A is allways sorted).
3) The module copied those records to another file/sheet (after first emptying those file/sheet) and fills in column X the data/time of the copy action, so the user can see that those ones are copied.

The second module;
This should be a follow up action of the first module.
If in the selection of bullit 3, in column L no data was registrated, then a message should popup with those information (= records xxx were empty).

regards, Johan (and thanks for helping me out !!)

Select rows that are 'blinking'

Hi Johan,

Am Sat, 26 Nov 2016 14:42:45 +0100 schrieb Claus Busch:

try following macro. Modify the sheet names where necessary:

Sub CopyRows2()

if you want it case sensitive then try:

Sub CopyRows3()
Dim wshS As Worksheet, wshT As Worksheet
Dim wbkS As Workbook, wbkT As Workbook
Dim varFilter As Variant, varTmp() As String
Dim varData As Variant, varRows() As Variant
Dim myDic As Object
Dim i As Long, LrowS As Long, n As Long, j As Long, LCol As Long
Dim rngC As Range
Dim myPath As String

Set wbkS = ActiveWorkbook
Set wshS = wbkS.ActiveSheet
Application.ScreenUpdating = False

With wshS
LrowS = .Cells(.Rows.Count, "A").End(xlUp).Row
varData = .Range("A1:A" & LrowS)
For Each rngC In Intersect(Selection, .Columns("A"))
ReDim Preserve varTmp(n)
varTmp(n) = rngC
n = n + 1
Next

Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(varTmp) To UBound(varTmp)
myDic(varTmp(i)) = varTmp(i)
Next
varFilter = myDic.items
n = 0
For i = LBound(varFilter) To UBound(varFilter)
For j = 2 To UBound(varData)
If StrComp(varData(j, 1), varFilter(i), vbBinaryCompare) = 0 Then
ReDim Preserve varRows(n)
varRows(n) = j
n = n + 1
End If
Next
Next
myPath = wbkS.Sheets("Sheet1").Range("F2")
If Dir(myPath) < "" Then
Set wbkT = Workbooks.Open(myPath)
Set wshT = wbkT.Sheets("Sheet1")
wshT.UsedRange.ClearContents
Else
MsgBox "Workbook not available. Macro is canceled"
End If
n = 2
For i = LBound(varRows) To UBound(varRows)
.Rows(varRows(i)).Copy wshT.Cells(n, 1)
n = n + 1
Next
End With
wshT.Range("X2").Resize(UBound(varRows) + 1) = Format(Now, "dd.Mm.yyyy \/ hh:mm:ss")

wbkT.Close savechanges:=True
Application.ScreenUpdating = True
End Sub

Regards
Claus B.
--
Windows10
Office 2016