Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Excel VBA script to populate a new sheet

Posted on 2015-01-29
6
Medium Priority
?
257 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 2000 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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 

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

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

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

If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
Explore the ways to Unlock VBA Project Password Excel 2010 & 2013 documents. Go through the article and perform the steps carefully to remove VBA Excel .xls file.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

926 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