Solved

Excel VBA script to populate a new sheet

Posted on 2015-01-29
6
251 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
[X]
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
  • 4
  • 2
6 Comments
 
LVL 18

Expert Comment

by:Simon
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:
Simon 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
Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

 

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

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

Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
This article describes a serious pitfall that can happen when deleting shapes using VBA.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

628 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