Solved

Excel VBA script to populate a new sheet

Posted on 2015-01-29
6
232 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: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
ScreenConnect 6.0 Free Trial

Explore all the enhancements in one game-changing release, ScreenConnect 6.0, based on partner feedback. New features include a redesigned UI, app configurations and chat acknowledgement to improve customer engagement!

 

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

Master Your Team's Linux and Cloud Stack

Come see why top tech companies like Mailchimp and Media Temple use Linux Academy to build their employee training programs.

Question has a verified solution.

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

Suggested Solutions

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

770 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