Link to home
Start Free TrialLog in
Avatar of tomfolinsbee
tomfolinsbee

asked on

Excel VBA script to populate a new sheet

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
Avatar of Simon
Simon
Flag of United Kingdom of Great Britain and Northern Ireland image
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

Avatar of tomfolinsbee
tomfolinsbee

ASKER

Thank you. Works great.

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

Again, thanks!
ASKER CERTIFIED SOLUTION
Avatar of Simon
Simon
Flag of United Kingdom of Great Britain and Northern Ireland image
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of tomfolinsbee
tomfolinsbee

ASKER

Much appreciated, worked like a charm :)
Avatar of tomfolinsbee
tomfolinsbee

ASKER

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!