Posts by jan_g

Option Explicit
Sub Export()       '----Create a list of products for export - require 1 row for each size orderd
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, n As Integer

Set ws1 = Worksheets("Data")
Set ws2 = Worksheets("Export")

 Application.ScreenUpdating = False
 
 '-----Clear Existing Results
 With ws2.Cells(1, 1)
 .CurrentRegion.ClearContents
 End With
 
 '-----Replicate Rows based on Counts
On Error Resume Next

For i = 3 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
 
    n = WorksheetFunction.CountIf(ws1.Range("H" & i & ": M" & i), ">0")  'Count the number of cells with data in cols H-M
    ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Offset(1).Resize(n, 4).Value = ws1.Cells(i, 2).Resize(, 4).Value  ' Insert "n" rows & get data Cols B-E
    ws2.Cells(ws2.Rows.Count, 5).End(xlUp).Offset(1).Resize(n, 1).Value = ws1.Cells(i, 7).Resize(, 1).Value  ' Get the RRP
    
    '-----???This section is not giving the desired result
    '-----Get the sizes
    For j = 8 To 13
        If (IsNumeric(Left(ws1.Cells(i, 6).Value, 1))) = True Then
                    ws2.Cells(ws2.Rows.Count, 6).End(xlUp).Offset(1).Resize(ws1.Cells(i, j).Value, 1).Value = ws1.Cells(2, j).Resize(1, j).Value
              Else
                    ws2.Cells(ws2.Rows.Count, 6).End(xlUp).Offset(1).Resize(ws1.Cells(i, j).Value, 1).Value = ws1.Cells(1, j).Resize(1, j).Value
        End If
    Next j
Next i

Application.CutCopyMode = False
End Sub

Sub transposeColumns()
    Dim R1 As Range
    Dim R2 As Range
    Dim R3 As Range
    Dim RowN As Integer
    wTitle = "Transpose multiple rows/columns"
    Set R1 = Application.Selection
    Set R1 = Application.InputBox("Select the Source data of Ranges to be copied:", wTitle, R1.Address, Type:=8)
    Set R2 = Application.InputBox("Select one destination Cell or column:", wTitle, Type:=8)
    RowN = 0
    Application.ScreenUpdating = False
    For Each R3 In R1.Rows
        R3.copy
        R2.Offset(RowN, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        RowN = RowN + R3.Columns.Count
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Option Explicit
Sub NewList2() 'Create a list of product info for Import

Dim shO As Worksheet, shL As Worksheet
Dim i As Long, j As Long, n As Integer

Set shO = Worksheets("Data")
Set shL = Worksheets("Export List")

Application.ScreenUpdating = False
 
 '-----Clear Existing Results
With shL.Cells(1, 1)
 .CurrentRegion.ClearContents
End With
 
 '-----Replicate Rows based on Counts
On Error Resume Next

For i = 4 To shO.Cells(shO.Rows.Count, 2).End(xlUp).Row
    n = WorksheetFunction.CountIf(shO.Range("H" & i & ": M" & i), ">0")  'Count the number of cells with data in cols H-M
    shL.Cells(shL.Rows.Count, 1).End(xlUp).Offset(1).Resize(n, 4).Value = shO.Cells(i, 2).Resize(, 4).Value  ' Insert "n" rows & get data Cols B-E
    shL.Cells(shL.Rows.Count, 5).End(xlUp).Offset(1).Resize(n, 1).Value = shO.Cells(i, 7).Resize(, 1).Value ' Get the RRP

Next i

Application.CutCopyMode = False
End Sub

Sub NewList() 'Create a list of product info for Import

Dim shO As Worksheet, shL As Worksheet
Dim lastrow As Long, i As Long, j As Long, cnt As Long
Dim rng As Range
cnt = 0

Set shO = Worksheets("Data")
Set shL = Worksheets("Export List")

 Application.ScreenUpdating = False
 
 '-----Clear List
 With shL.Cells(1, 1)
 .CurrentRegion.ClearContents
 End With
 
 '-----Replicate Rows based on Counts
 On Error Resume Next
 For i = 4 To shO.Cells(shO.Rows.Count, 2).End(xlUp).Row
 For j = 8 To 13
 'cnt.FormulaR1C1 = "=COUNTIF(RiC7:RiC12,>0)" 'Cannot get this to work. Will replace col references below with variable
 
 shL.Cells(shL.Rows.Count, 1).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 4).Value = shO.Cells(i, 2).Resize(, 4).Value ' Get data first 4 columns from Orders
 
 If (IsNumeric(Left(shO.Cells(i, 6).Value, 1))) = True Then
    shL.Cells(shL.Rows.Count, 5).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 1).Value = shO.Cells(3, j).Resize(1, 14).Value
 Else
    shL.Cells(shL.Rows.Count, 5).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 1).Value = shO.Cells(2, j).Resize(1, j).Value
 End If
 shL.Cells(shL.Rows.Count, 6).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 1).Value = shO.Cells(i, 7).Resize(, 1).Value ' Get the RRP
 Next j
 Next i

 
Application.CutCopyMode = False
End Sub

Option Explicit
Sub NewList() 'Create a list of product info for Import

Dim shO As Worksheet, shL As Worksheet
Dim lastrow As Long, i As Long, j As Long, cnt As Long
Dim rng As Range
cnt = 0

Set shO = Worksheets("Data")
Set shL = Worksheets("Export List")

 Application.ScreenUpdating = False
 
 '-----Clear List
  With shL.Cells(1, 1)
        .CurrentRegion.ClearContents
    End With
    
 '-----Replicate Rows based on Counts
    On Error Resume Next
    For i = 4 To shO.Cells(shO.Rows.Count, 2).End(xlUp).Row
      
       'cnt.FormulaR1C1 = "=COUNTIF(RiC7:RiC12,>0)"   'Cannot get this to work. Will replace col references below with variable
       
            shL.Cells(shL.Rows.Count, 1).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 4).Value = shO.Cells(i, 2).Resize(, 4).Value ' Get data first 4 columns from Orders
            If (IsNumeric(Left(shO.Cells(i, 6).Value, 1))) = True Then
                    shL.Cells(shL.Rows.Count, 5).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 1).Value = shO.Cells(7, j).Resize(1, j).Value
                Else
                    shL.Cells(shL.Rows.Count, 5).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 1).Value = shO.Cells(6, j).Resize(1, j).Value
            End If
            shL.Cells(shL.Rows.Count, 6).End(xlUp).Offset(1).Resize(shO.Cells(i, 14).Value, 1).Value = shO.Cells(i, 6).Resize(, 1).Value ' Get the RRP
                    
    Next i
Application.CutCopyMode = False
End Sub

Option Explicit
Sub Maybe()
Dim shP As Worksheet, shL As Worksheet
Dim i As Long, j As Long, n As Integer
Set shP = Worksheets("Products")
Set shL = Worksheets("Label")

    With shL.Cells(1, 1)
        .CurrentRegion.ClearContents
        .Resize(, 8) = shP.Cells(1, 1).Resize(, 8).Value
    End With
    
    For i = 2 To shP.Cells(shP.Rows.Count, 1).End(xlUp).Row
        For j = 4 To 8
           
            shL.Cells(shL.Rows.Count, 1).End(xlUp).Offset(1).Resize(shP.Cells(i, j).Value, 8).Value = shP.Cells(i, 1).Resize(, 8).Value
            shL.Cells(shL.Rows.Count, 9).End(xlUp).Offset(1).Resize(shP.Cells(i, j).Value, 1).Value = shP.Cells(1, j).Resize(1, j).Value
       
        Next j
    Next i
End Sub

Sub Labels2()

Dim lastrow As Long
Dim rng As Range
lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
 
Application.ScreenUpdating = False
 
'Clear Labels Sheet
Sheet1.Cells.Clear
  
'Copy Columns
With Sheet2
    .Activate
    .Range("A2:C" & lastrow & ", E2:J" & lastrow).Copy Sheet1.Range("A1")
End With

Application.CutCopyMode = False

'Remove any blank rows
Sheet1.Select
N = Cells(Rows.Count, "C").End(xlUp).Row
    For I = N To 1 Step -1
        Set r = Cells(I, "c")
        If IsEmpty(r) Then
            r.EntireRow.Delete
        End If
    Next
    
'Replicate Rows based on the Value in Col I
    Range("a1:i1").Copy Range("k1")
    On Error Resume Next
    For Each rng In Range("I2", Range("I" & Rows.Count).End(xlUp))
        Cells(Rows.Count, 11).End(xlUp)(2).Resize(rng.Value, 9) = rng.Offset(, -8).Resize(1, 9).Value
    Next rng
    
End Sub

Dim oTbl1 As ListObject, oTbl2 As ListObject
Dim iX As Integer, iCnt As Integer
Set oTbl1 = Sheet1.ListObjects("TableA")
Set oTbl2 = Sheet1.ListObjects("TableB")

If oTbl1.ListRows.Count > oTbl2.ListRows.Count Then
iCnt = oTbl1.ListRows.Count - oTbl2.ListRows.Count
MsgBox iCnt
For iX = 1 To iCnt
''/// AlwaysInsert:=True: specifies whether to always shift data in cells below the last row of the table
oTbl2.ListRows.Add AlwaysInsert:=True
Next iX


ElseIf oTbl1.ListRows.Count < oTbl2.ListRows.Count Then
    iCnt = oTbl2.ListRows.Count - oTbl1.ListRows.Count

    For iX = 1 To iCnt

oTbl2.ListRows(1).Delete
    Next iX
    
End If


End Sub