Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium


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


Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

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

Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
Windows Explorer lets you open cabinet (cab) files like any other folder. In VBA you can easily handle normal files and folders, but opening and indeed creating cabinet files takes a lot more - and that's you'll find here.
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…
How can you see what you are working on when you want to see it while you to save a copy? Add a "Save As" icon to the Quick Access Toolbar, or QAT. That way, when you save a copy of a query, form, report, or other object you are modifying, you…

564 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