Macro code for excel

[Dartit]

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.

Model	Product Nr	SAP NR	QTY
DL360 G3	DL360-G3-00	30452168	3
DL460 G2	DL360-G2-00	35412870	2
DL260 G1	DL260-G1-00	35614268	7

<tbody>
</tbody>

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.

identifikator		Opprett/endre utstyr		Motaksbekreftelse
Modell	Produkt nr	serie nr	Materiell nr	Mottatt dato	lager kode
DL360 G3	DL360-G3-00		30452168
DL360 G3	DL360-G3-00		30452168
DL360 G3	DL360-G3-00		30452168

<tbody>
</tbody>

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

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.

 

[Fluff]

Hi & welcome to MrExcel
How about

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

 

[Dartit]

Thank you very much. That worked out brilliantly

 

[Fluff]

Glad to help & thanks for the feedback