Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 118
  • Last Modified:

Follow up question to Q_28606695.html

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
tomfolinsbee
Asked:
tomfolinsbee
  • 2
1 Solution
 
SimonCommented:
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
 
SimonCommented:
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
 
tomfolinsbeeAuthor Commented:
Simon, thanks for doing this so quickly. Worked fine. Cheers!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now