Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17


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
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

670 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