Macro code for excel

Dartit

New Member
Joined
Apr 17, 2018
Messages
5
Hiya

I am struggeling to create a macro that wil simplefy my report making a little. I have a set of items I need to report serial numbers on each month and the items are not always the same.

I have created myseld a Data sheet where I will input the data (se sample) some days there can be 20 lines + and sometimes there are only a few.

[TABLE="class: grid, width: 349"]
<tbody>[TR]
[TD]Model[/TD]
[TD]Product Nr[/TD]
[TD]SAP NR[/TD]
[TD]QTY[/TD]
[/TR]
[TR]
[TD]DL360 G3[/TD]
[TD]DL360-G3-00[/TD]
[TD="align: right"]30452168[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD]DL460 G2[/TD]
[TD]DL360-G2-00[/TD]
[TD="align: right"]35412870[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]DL260 G1[/TD]
[TD]DL260-G1-00[/TD]
[TD="align: right"]35614268[/TD]
[TD="align: right"]7[/TD]
[/TR]
</tbody>[/TABLE]

What I need is for the macro to create new tabs in the same workbook using the SAP NR as the naming convention for these tabs, as these numbers are unique for different items.

Additionally I would like for the macro to past the model/produkt nr and SAP nr of the corresponding tab and I would like for it to duplicate itself based on the quantity in the data sheet.

So it looks like this in each tab.

[TABLE="class: grid, width: 562"]
<tbody>[TR]
[TD]identifikator[/TD]
[TD][/TD]
[TD]Opprett/endre utstyr[/TD]
[TD][/TD]
[TD="colspan: 2"]Motaksbekreftelse[/TD]
[/TR]
[TR]
[TD]Modell[/TD]
[TD] Produkt nr[/TD]
[TD]serie nr[/TD]
[TD]Materiell nr[/TD]
[TD]Mottatt dato[/TD]
[TD] lager kode[/TD]
[/TR]
[TR]
[TD]DL360 G3[/TD]
[TD]DL360-G3-00[/TD]
[TD][/TD]
[TD="align: right"]30452168[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]DL360 G3[/TD]
[TD]DL360-G3-00[/TD]
[TD][/TD]
[TD="align: right"]30452168[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]DL360 G3[/TD]
[TD]DL360-G3-00[/TD]
[TD][/TD]
[TD="align: right"]30452168[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

The empty cells is where i input the data at a later stage.

As i am new to VBA I am struggeling to find a way to creat this code. I have managed to code a macro that creats tabs for me, however i am struggeling to amend this so that it will do the other thing.
The code I have been playing with is

Code:
Sub parse_data()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer


vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"


For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Is there any way to amend this code to suit my needs?

Sorry for the long post and thank you for your help in this matter.
 
Last edited by a moderator:

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Hi & welcome to MrExcel
How about
Code:
Sub parse_data()

   Dim Ws As Worksheet
   Dim Ary As Variant
   Dim i As Long, j As Long
   Dim Cl As Range
   Dim UsdRws As Long
   Dim TitlA As Variant
   Dim TitlB As Variant

Application.ScreenUpdating = False

   TitlA = Array("dentifikator", , "Opprett/endre utstyr", , "Motaksbekreftelse")
   TitlB = Array("Modell", "Produkt nr", "serie nr", "Materiell nr", "Mottatt dato", "lager kode")
   Set Ws = Sheets("Setup")
   
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   UsdRws = Ws.Range("C" & Rows.count).End(xlUp).Row
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("C2:C" & UsdRws)
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
               Sheets.Add(, Sheets(Sheets.count)).Name = Cl.Value
               Sheets(Cl.Text).Range("A1:E1").Value = TitlA
               Sheets(Cl.Text).Range("A2:F2").Value = TitlB
            End If
            Ws.Range("A1:D1").AutoFilter 3, Cl.Value
            Ary = Ws.Range("A2:D" & UsdRws).SpecialCells(xlVisible)
            j = UBound(Ary, 2)
            For i = 1 To UBound(Ary, 1)
               Sheets(Cl.Text).Range("A" & Rows.count).End(xlUp).Offset(1).Resize(Ary(i, j)).Value = Ary(i, 1)
               Sheets(Cl.Text).Range("B" & Rows.count).End(xlUp).Offset(1).Resize(Ary(i, j)).Value = Ary(i, 2)
               Sheets(Cl.Text).Range("D" & Rows.count).End(xlUp).Offset(1).Resize(Ary(i, j)).Value = Ary(i, 3)
            Next i
            Ary = ""
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
   Ws.Activate

End Sub
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,223,885
Messages
6,175,182
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top