Solved

Excel VBA script to populate a new sheet

Posted on 2015-01-29
6
218 Views
Last Modified: 2016-02-10
Hello Experts

I'm looking for help with an Excel VBA script to populate a new sheet

Attached file has sample data.

Here's the logic:
If a tab name contains 入出 and If row 3 contains 日,  then From row 5 to bottom, if a cell has value,  copy and paste cells from col A-E from same row, and from row 3 (same column) (date) to the new table.

Thanks!
EE20150129.xlsx
0
Comment
Question by:tomfolinsbee
  • 4
  • 2
6 Comments
 
LVL 18

Expert Comment

by:SimonAdept
ID: 40578710
This does what I think you want.
It create a new worksheet in the workbook to list the results.
It finds the correct sheet by using ChrW to match the unicode characters
It finds the required character in row 3 then scans down the rest of the column to find rows with values in.
It copies the first 5 columns, plus the relevant 'date' column header pluse the values to the new worksheet.

I get seven rows of results from your example workbook by using it.

Sub test()

Set newsht = ActiveWorkbook.Worksheets.Add
newshtRow = 1

For Each sht In ActiveWorkbook.Sheets
    Debug.Print sht.Name
    shtname = sht.Name
    For x = 1 To Len(shtname)
        Debug.Print Mid(shtname, x, 1), Asc(Mid(shtname, x, 1)), AscW(Mid(shtname, x, 1))
    Next
    
    If sht.Name Like "*" & ChrW(20837) & ChrW(20986) & "*" Then
    Debug.Print "unicode 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
                For Each rw In .Range(.Cells(5, c.Column), .Cells(usedrows, c.Column)).Cells
                    If rw.Value <> "" Then
                        Debug.Print rw.Address, rw.Value
                        Set copyrange = .Range(.Cells(rw.Row, 1), .Cells(rw.Row, 5))
                        newsht.Range(Cells(newshtRow, 1), 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
                        newshtRow = newshtRow + 1
                    Else
                        'Debug.Print rw.Address, "empty"
                    End If
                Next
            End If
        Next y
    
        Next c

    End With
    
    End If

Next sht

MsgBox "Finished"
End Sub

Open in new window

0
 

Author Comment

by:tomfolinsbee
ID: 40578828
Thank you. Works great.

Could I ask you to make one modification -- add cell C1 and H1  to each output row?

Again, thanks!
0
 
LVL 18

Accepted Solution

by:
SimonAdept earned 500 total points
ID: 40579240
Here it is. Note the cell C1 value is blank. You may want A1 or a part of its value?

Sub test()

Set newsht = ActiveWorkbook.Worksheets.Add
newsht.Name = "Results"
newshtRow = 1

For Each SHT In ActiveWorkbook.Sheets
    Debug.Print SHT.Name
    shtname = SHT.Name
    For x = 1 To Len(shtname)
        Debug.Print Mid(shtname, x, 1), Asc(Mid(shtname, x, 1)), AscW(Mid(shtname, x, 1))
    Next
    
    If SHT.Name Like "*" & ChrW(20837) & ChrW(20986) & "*" Then 'Match two characters in worksheet name
    Debug.Print "unicode 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 <> "" Then
                        Debug.Print rw.Address, rw.Value
                        Set copyrange = .Range(.Cells(rw.Row, 1), .Cells(rw.Row, 5))
                        newsht.Range(Cells(newshtRow, 1), 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
    
    End If

Next SHT

MsgBox "Finished"
End Sub

Open in new window

0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 

Author Closing Comment

by:tomfolinsbee
ID: 40579660
Much appreciated, worked like a charm :)
0
 

Author Comment

by:tomfolinsbee
ID: 40610189
Hi Simon,

Could you modify the script so that it puts the "in"  (入庫数) and "out"  (出庫数) as separate rows?

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.

I'll set up a new question.

Thanks!
0
 

Author Comment

by:tomfolinsbee
ID: 40610201
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Suggested Solutions

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

746 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

9 Experts available now in Live!

Get 1:1 Help Now