VBA/Formula logic Advice

[VBA learner ITG]

Hi all,


I have an VBA/Formula logic issue which I hope to pick your brains on.


Step 1 - user completes a data table from column C row 2 onward which tells a macro how many times to duplicate the row by per column B row 2.


I have a formula which then populates column A row 2 with the column header:


=IF(COUNTA($B2:$D2)=0,"",INDEX($B$1:$G$1,MATCH(FALSE,INDEX(ISBLANK($B2:$G2),0),0)))




However the above formula will only populate the first column Name which is great if we are not duplicating the rows.


However, the issue is that I need to populate the column header of the row that has been duplicated so it looks at the column after the first one of that row.




Step 2 - this is what the finished data table should look like.


Any advice would be appreciated.

 

[nikio8]

Hi,
why use that formual at all? it will not duplicate your rows?

j=1
sheet(1).row(3).copy destination:=sheet(2).cells(j,1)
for r = 4 to lastRowA ' say you populate 1st row with data
    for c = 3 to 7
        if sheet(1).(r,c).value <> "" then
          sheet(1).row(3).copy destination:=sheet(2).cells(j,1)
          sheet(2).cells(j,1).value=sheet(1).cells(3,c)
          j=j+1

    end if
  next c
next r

 

[VBA learner ITG]

Hi Nikio8,

This is the code that I have been toying with that incorporates the formula that I mentioned.

Due to the duplicated row I needed advice on an alternative logic to apply based on the duplicate row.

Sub CopyData()




    Dim ShName As String
    Dim xRow As Long
    Dim VInSertNum As Variant
    xRow = 1
    Application.ScreenUpdating = False
    
    'CREATE COPY SHEET




With ActiveSheet
ShName = .Name & "Copy"
.Copy After:=Sheets(Worksheets.Count)
End With
Sheets(Worksheets.Count).Name = ShName
   
       
    
    Do While (Cells(xRow, "B") <> "")
        VInSertNum = Cells(xRow, "AAA")
        If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
           Range(Cells(xRow, "B"), Cells(xRow, "AAA")).Copy
           Range(Cells(xRow + 1, "B"), Cells(xRow + VInSertNum - 1, "AAA")).Select
           Selection.Insert Shift:=xlDown
           xRow = xRow + VInSertNum - 1
        End If
        xRow = xRow + 1
    Loop
    
    
    
    'FILL DOWN FORMULA
Dim Lastrow As Long
Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Row).Formula = "=IFERROR(INDEX(R1C48:R1C702,MATCH(TRUE,INDEX(RC48:RC702>0,0),0)),"""")"
'Range("A2:A" & Lastrow).FillDown
   
    Application.ScreenUpdating = False
End Sub

 

[nikio8]

hi, cannot help you much,
i thought my code did what you wanted, i did not test it as it is a bit unclear what you want to do, i do not understand the index formula. (made slight mistake.)

go to row 4, check each column, if not empty field found, copy entire row
go to row 5...

'copy heading row
sheet(1).row(3).copy destination:=sheet(2).cells(1,1)
j=2

'each time non empty row is found copy entire row
for r = 4 to lastRowA ' say you populate 1st row with data
for c = 3 to 7
if sheet(1).cells(r,c).value <> "" then
sheet(1).row(r).copy destination:=sheet(2).cells(j,1) 'copy entire row
sheet(2).cells(j,1).value=sheet(1).cells(3,c) 'overwrite first value to be heading of non blank column
j=j+1

end if
next c
next r

 

[VBA learner ITG]

Hi Nikio,

I have found a solution to my issue, which i hope helps everyone else who has to undertake this task.

Option Explicit
Const TitleRow As Integer = 1
Const StartGenColumn As Integer = 47  ' AU


Sub GenerateRows()
Dim SrcRow As Integer, DestRow As Integer, SrcCol As Integer
Dim NumCoreColumns As Integer, LastGenColumn As Integer
Dim SrcWS As Worksheet, DestWS As Worksheet
Dim i As Integer


    NumCoreColumns = StartGenColumn - 1
    ' find the last column
    LastGenColumn = ActiveSheet.Cells(TitleRow, ActiveSheet.Columns.Count).End(xlToLeft).Column
    ' check if it has the totals
    If InStr(ActiveSheet.Cells(TitleRow + 1, LastGenColumn).Formula, "SUM") Then
        LastGenColumn = LastGenColumn - 1
    Else
        ' put in a total so that we can tell when we've finished processing
        ActiveSheet.Cells(TitleRow + 1, LastGenColumn + 1).Formula = "=SUM(" & ColLetter(StartGenColumn) & (TitleRow + 1) & _
                    ":" & ColLetter(LastGenColumn) & (TitleRow + 1) & ")"
        ' fill down
        ActiveSheet.Range(Cells(TitleRow + 1, LastGenColumn + 1), Cells(ActiveSheet.Rows.Count, LastGenColumn + 1)).FillDown
    End If
    Set SrcWS = ActiveSheet
    
    If LastGenColumn > StartGenColumn Then
        ' create the new worksheet
        Worksheets.Add
        Set DestWS = ActiveSheet
        
        Application.ScreenUpdating = False
        ' populate the titles
        SrcWS.Range(SrcWS.Cells(TitleRow, 1), SrcWS.Cells(TitleRow, NumCoreColumns)).Copy
        ' always at top of new sheet
        DestWS.Range(DestWS.Cells(1, 1), DestWS.Cells(1, NumCoreColumns)).PasteSpecial xlPasteAll
        SrcRow = TitleRow + 1
        DestRow = 2
        ' while we still have something to do
        Do While SrcWS.Cells(SrcRow, LastGenColumn + 1) <> "" And SrcWS.Cells(SrcRow, LastGenColumn + 1) > 0
            ' copy the core data
            SrcWS.Range(SrcWS.Cells(SrcRow, 1), SrcWS.Cells(SrcRow, NumCoreColumns)).Copy
            ' what to we need to generate
            For SrcCol = StartGenColumn To LastGenColumn
                For i = 1 To SrcWS.Cells(SrcRow, SrcCol).Value
                    DestWS.Range(DestWS.Cells(DestRow, 1), DestWS.Cells(DestRow, NumCoreColumns)).PasteSpecial xlPasteAll
                    ' copy in the title and colour
                    DestWS.Cells(DestRow, 1).Value = SrcWS.Cells(TitleRow, SrcCol).Value
                    DestWS.Cells(DestRow, 1).Interior.Color = SrcWS.Cells(TitleRow, SrcCol).Interior.Color
                    DestRow = DestRow + 1
                Next i
            Next SrcCol
            SrcRow = SrcRow + 1
        Loop
        Application.CutCopyMode = False
        DestWS.Cells(1, 1).EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End If
End Sub


Private Function ColLetter(Col As Integer) As String
Dim Arr
Arr = Split(Cells(1, Col).Address(True, False), "$")
ColLetter = Arr(0)
End Function

 

[VBA learner ITG]

Thank you for taking the time to help me. I really appreciate your assistance.