Go Premium for a chance to win a PS4. Enter to Win


Follow up question to Q_28606695.html

Posted on 2015-02-14
Medium Priority
Last Modified: 2016-02-11
This is a follow up question to:

I'd like to modify the script so that it puts the "in" and "out" into individual rows, rather than treating them as pairs.

Question by:tomfolinsbee
  • 2
LVL 18

Expert Comment

ID: 40610681
Hi Tom, before I start on this, did you have a preference for this question I posed in the previous thread?
Tom: Could I ask you to make one modification -- add cell C1 and H1  to each output row?
Simon: Note the cell C1 value is blank. You may want A1 or a part of its value?
In the case you mentioned:
I just noticed the the script skipped the value of 25 in cell BQ10, perhaps because BP10 was empty, or because the top row used merged cells.
It was skipped because BP10 was empty. Do you still want a separate line for this in the result sheet (so that you have a matching pair of 'in' and 'out' lines?
LVL 18

Accepted Solution

Simon earned 2000 total points
ID: 40610744
So I could get this done before going out for the day...
Option Explicit

Sub tf3()
Dim sht As Worksheet
Dim newSht As Worksheet
Dim newshtRow As Integer
Dim shtName As String
Dim usedRows As Integer
Dim c As Range
Dim y As Integer
Dim myDate As Variant
Dim myC1 As Variant
Dim myH1 As Variant
Dim rw As Range
Dim copyRange As Range

For Each sht In ActiveWorkbook.Sheets
    If sht.Name = "Results" Then
        If MsgBox("OK to clear Results sheet?", vbOKCancel) = vbCancel Then Exit Sub Else
        Set newSht = sht
        newshtRow = 1
        Exit For
    End If

If newSht Is Nothing Then
    Set newSht = ActiveWorkbook.Worksheets.Add
    newSht.Name = "Results"
    newshtRow = 1
End If

For Each sht In ActiveWorkbook.Sheets
    Debug.Print sht.Name
    shtName = sht.Name
    If shtName Like "*" & ChrW(20837) & ChrW(20986) & "*" Then 'Match two characters in worksheet name
        With sht
            usedRows = .UsedRange.Rows.Count
            For Each c In Intersect(.Rows(3), .UsedRange).Cells
                Debug.Print c.Value
                For y = 1 To Len(c.Value)
                    Debug.Print Mid(c.Value, y, 1), Asc(Mid(c.Value, y, 1)), AscW(Mid(c.Value, y, 1))
                    If AscW(Mid(c.Value, y, 1)) = 26085 Then
                        myDate = c.Value
                        myC1 = .Range("C1").Value
                        myH1 = .Range("H1").Value
                        For Each rw In .Range(.Cells(5, c.Column), .Cells(usedRows, c.Column)).Cells
                            If rw.Value <> "" Or rw.Offset(0, 1).Value <> "" Then 'Look for values either in the cell directly below the date header ('In') or 1 to the right ('Out')
                                Debug.Print rw.Address, rw.Value
                                Set copyRange = .Range(.Cells(rw.Row, 1), .Cells(rw.Row, 5))
                                newSht.Range(newSht.Cells(newshtRow, 1), newSht.Cells(newshtRow, 5)).Value = copyRange.Value
                                newSht.Cells(newshtRow, 6).Value = myDate
                                newSht.Cells(newshtRow, 7).Value = rw.Value
                                'newsht.Cells(newshtRow, 8).Value = rw.Offset(0, 1).Value
                                newSht.Cells(newshtRow, 9).Value = myC1
                                newSht.Cells(newshtRow, 10).Value = myH1
                                newshtRow = newshtRow + 1
                                'Separate line for the 'Out' value
                                newSht.Range(newSht.Cells(newshtRow, 1), newSht.Cells(newshtRow, 5)).Value = copyRange.Value
                                newSht.Cells(newshtRow, 6).Value = myDate
                                'newsht.Cells(newshtRow, 7).Value = rw.Value
                                newSht.Cells(newshtRow, 8).Value = rw.Offset(0, 1).Value
                                newSht.Cells(newshtRow, 9).Value = myC1
                                newSht.Cells(newshtRow, 10).Value = myH1
                                newshtRow = newshtRow + 1
                                'Debug.Print rw.Address, "empty"
                            End If
                    End If
                Next y
            Next c
        End With 'with sht
    End If 'Check whether sheet name contains the two unicode characters

Next sht

MsgBox "Finished"
End Sub

Open in new window

I assumed you would want the 'in' line even if blank if there was a value in the 'out' cell. I can tweak this quickly if required.

Author Closing Comment

ID: 40619913
Simon, thanks for doing this so quickly. Worked fine. Cheers!

Featured Post

Ask an Anonymous Question!

Don't feel intimidated by what you don't know. Ask your question anonymously. It's easy! Learn more and upgrade.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Windows Explorer let you handle zip folders nearly as any other folder: Copy, move, change, and delete, etc. In VBA you can also handle normal files and folders, but zip folders takes a little more - and that you'll find here.
In a use case, a user needs to close an opened report by simply pressing the Escape (Esc) key. This can be done by adding macro code in Report_KeyPress or Report_KeyDown event.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

886 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question