Solved

Follow up question to Q_28606695.html

Posted on 2015-02-14
3
62 Views
Last Modified: 2016-02-11
This is a follow up question to:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28606695.html

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

Thanks!
0
Comment
Question by:tomfolinsbee
  • 2
3 Comments
 
LVL 18

Expert Comment

by:Simon
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?
And...
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?
0
 
LVL 18

Accepted Solution

by:
Simon earned 500 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
        sht.Cells.Clear
        newshtRow = 1
        Exit For
    End If
Next

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
                            Else
                                'Debug.Print rw.Address, "empty"
                            End If
                        Next
                    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.
0
 

Author Closing Comment

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

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

911 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now