VBA required for Columns to rows

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
243
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Here are the requirements I am trying to figure out a VBA code for.
Please help write a VBA code based on the requirements below.
Thank you.

Copy from WRKBOOK 1 to WRKBOOK 2
WRKBOOK 1 Columns G, H, I, J - Must create a new line if there is an entry, as shown in WRKBOOK 2
WRKBOOK 2 Columns A, B, C, D, E, F remains the same, only the quantity changes
Want an easy-to-modify VBA script so if there are additional columns added after WRKBOOK 1 Col F, or I, or j etc., can be easily modified.

EXAMPLEEXAMPLEEXAMPLEEXAMPLEEXAMPLEEXAMPLEcode1code2code3code4
TYPEstateZONEabs1respemsDOA
LINEDIGITNOMAutoAutoAutoQTYQTYQTYQTY
111111SmithteaBCred29
244444DrumphsnodDEorange1
356789ChuckdokZAblue1235
WRKBOOK 1


LINEDIGITNOMTYPESTATEZONEDIRQTY*
111111SmithteaBCredabs12
111111SmithteaBCredems9
244444DrumphsnodDEorangeems1
356789ChuckdokZAblueabs11
356789ChuckdokZAblueresp2
356789ChuckdokZAblueems3
356789ChuckdokZAblueDOA5
WRKBOOK 2
 
Sort by date Sort by votes

Dossfm0q Thank you so much for creating all the codes. I will test this out as well. So many things I've learned from this thread.​

alansidman Thanks for the link. I will take some time to learn the Power Query and test your script too.​

 
Upvote 0

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

Dossfm0q , it is two separate Workbooks, so two separate files.​


Sorry, did you mean by WORKBOOK 1 and WORKBOOK 2 separated Excel files or One Excel file with 2 worksheets named as worksheets("WORKBOOK 1") and worksheets("WORKBOOK 2")
Click to expand...
 
Upvote 0
maabadi said:
What about this Macro:
VBA Code: 
Sub TransferData()
Dim I as Long, Lr1 as Long, Lr2 as Long, C as Long, j as long, k as long
Dim Sh1 as worksheet, Sh2 as worksheet, Wb1 as workbook, Wb2 as workbook
Application.ScreenUpdating = False
'Set wb1 = Workbooks("Book1.xlsx")
'Set wb2 = Workbooks("Book2.xlsx")
Set Sh1 = Sheets("Sheet1")        'With Workbook this is     Set Sh1 = wb1.Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")        'With Workbook this is     Set Sh2 = wb2.Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlup).Row
Sh2.Range("A1:C1").Value = Sh1.Range("A3:C3").Value
Sh2.Range("D1:F1").Value = Sh1.Range("D2:F2").Value
Sh2.Range("G1").Value = "DIR"
Sh2.Range("H1").Value = "QTY"
For I=5 to Lr1
Lr2 = Sh2.Cells(Rows.Count, 1).End(xlup).Row + 1
C = Application.worksheetfunction.Count(Sh1.Range("G" & I & ":J" & I))
Sh2.Range("A" &Lr2 + 1 & ":F" & Lr2 + C)).Value = Sh1.Range("A" & I & ":F" & I).Value
k = 1
For j=7 to 10
if Sh1.Cells(I, j).Value = "" Then
Else
Sh2.Range("G" &Lr2 + k) = Sh1.Cells(2, j)
Sh2.Range("H" &Lr2 + k) = Sh1.Cells(I, j)
k = k + 1
End if
Next j
Next I
Application.ScreenUpdating = True
End Sub
Click to expand...
I just tired the script and received a compile syntax error, and I don't know how to fix it.
VBA Code: 
Sh2.Range("A" &Lr2 + 1 & ":F" & Lr2 + C)).Value = Sh1.Range("A" & I & ":F" & I).Value
 
Upvote 0
What is your sheet names at 2 workbook? Are you change sheet names to your sheet names?
 
Upvote 0
BOOK1 & SHEET1 , BOOK2& sheet1
VBA Code: 
 Sub TransferData()
Dim I as Long, Lr1 as Long, Lr2 as Long, C as Long, j as long, k as long
Dim Sh1 as worksheet, Sh2 as worksheet, Wb1 as workbook, Wb2 as workbook Application.ScreenUpdating = False
Set wb1 = Workbooks("Book1.xlsx")
Set wb2 = Workbooks("Book2.xlsx")         
Set Sh1 = wb1.Sheets("Sheet1")     
Set Sh2 = wb2.Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlup).Row
Sh2.Range("A1:C1").Value = Sh1.Range("A3:C3").Value
Sh2.Range("D1:F1").Value = Sh1.Range("D2:F2").Value
Sh2.Range("G1").Value = "DIR"
Sh2.Range("H1").Value = "QTY"
For I=5 to Lr1
Lr2 = Sh2.Cells(Rows.Count, 1).End(xlup).Row + 1
C = Application.worksheetfunction.Count(Sh1.Range("G" & I & ":J" & I))
Sh2.Range("A" &Lr2 + 1 & ":F" & Lr2 + C)).Value = Sh1.Range("A" & I & ":F" & I).Value
k = 1
For j=7 to 10
if Sh1.Cells(I, j).Value = "" Then
Else
Sh2.Range("G" &Lr2 + k) = Sh1.Cells(2, j)
Sh2.Range("H" &Lr2 + k) = Sh1.Cells(I, j)
k = k + 1
End if
Next j
Next I
Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
BOOK1 & SHEET1 , BOOK2& sheet1
Sorry try this:
VBA Code: 
Sub TransferData()
Dim I as Long, Lr1 as Long, Lr2 as Long, C as Long, j as long, k as long
Dim Sh1 as worksheet, Sh2 as worksheet, Wb1 as workbook, Wb2 as workbook 
Application.ScreenUpdating = False
Set wb1 = Workbooks("Book1.xlsx")
Set wb2 = Workbooks("Book2.xlsx")
Set Sh1 = wb1.Sheets("Sheet1")
Set Sh2 = wb2.Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlup).Row
Sh2.Range("A1:C1").Value = Sh1.Range("A3:C3").Value
Sh2.Range("D1:F1").Value = Sh1.Range("D2:F2").Value
Sh2.Range("G1").Value = "DIR"
Sh2.Range("H1").Value = "QTY"
For I=5 to Lr1
Lr2 = Sh2.Cells(Rows.Count, 1).End(xlup).Row + 1
C = Application.worksheetfunction.Count(Sh1.Range("G" & I & ":J" & I))
Sh2.Range("A" &Lr2 + 1 & ":F" & Lr2 + C)).Value = Sh1.Range("A" & I & ":F" & I).Value
k = 1
For j=7 to 10
if Sh1.Cells(I, j).Value = "" Then
Else
Sh2.Range("G" &Lr2 + k) = Sh1.Cells(2, j)
Sh2.Range("H" &Lr2 + k) = Sh1.Cells(I, j)
k = k + 1
End if
Next j
Next I
Application.ScreenUpdating = True
End Sub
 
Upvote 0
this will create WorkBooks what are you need with 50 Rows have formula keeping file update

VBA Code: 
Public Sub Row_Col()
    Dim WB1 As Workbook, WB2 As Workbook, EWB As Workbook
    Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
    Dim Path As String
    Path = Environ("USERPROFILE") & "\Desktop\"
    
        File1Name = "WRKBOOK 1.xlsx"
        FullName = Path & File1Name
            
            On Error Resume Next
            Set EWB = Application.Workbooks(File1Name)
            If EWB Is Nothing Then
                If Dir(FullName) <> "" Then Kill FullName
                         Kill FullName
        
                Set WB1 = Workbooks.Add
            Else
            EWB.Close False
                If Dir(FullName) <> "" Then Kill FullName
                 Kill FullName
                Set WB1 = Workbooks.Add
            End If
            On Error GoTo 0
    
    With WB1
    
            .SaveAs Filename:=FullName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    
        TxT = "EXAMPLE,EXAMPLE,EXAMPLE,EXAMPLE,EXAMPLE,EXAMPLE,code1,code2,code3,code4" & _
              ";,,,TYPE,state,ZONE,abs1,resp,ems,DOA" & _
              ";LINE,DIGIT,NOM,Auto,Auto,Auto,QTY,QTY,QTY,QTY" & _
              ";,,,,,,,,," & _
              ";1,11111,Smith,tea,BC,red,2,,9," & _
              ";2,44444,Drumph,snod,DE,orange,,,1," & _
              ";3,56789,Chuck,dok,ZA,blue,1,2,3,5"
        Set WS1 = .Worksheets("Sheet1")
        With WS1
        
            Arr = Split(TxT, ";")
            For x = LBound(Arr) To UBound(Arr)
            .Range("A" & x + 1 & ":J" & x + 1) = (Split(Arr(x), ","))
            Next
        
        Set WS2 = Sheets.Add(After:=.Parent.Worksheets(.Name))
        
        End With
        With WS2
                ShtName = WS1.Name

               RWcLRngAdrs = WS1.Range("G5:J7").Address(True, True)
              
               AggFuctn = "AGGREGATE(15,6,((COLUMN(" & ShtName & "!" & RWcLRngAdrs & ")-COLUMN(" & ShtName & "!$G$5))+((ROW(" & ShtName & "!" & RWcLRngAdrs & ")-ROW(" & ShtName & "!$G$5))*COLUMNS(" & ShtName & "!" & RWcLRngAdrs & ")+1))/--(" & ShtName & "!" & RWcLRngAdrs & "<>0),ROWS($A$2:A2))"
              
               With .Cells(1, 1).Resize(1, 8)
               .Value = [{"LINE","DIGIT","NOM","TYPE","STATE","ZONE","DIR","QTY*"}]
                With .Interior
                    .Pattern = xlSolid
                    .Color = RGB(37, 97, 149)
                    .TintAndShade = 0
                End With
                With .Font
                    .Color = RGB(255, 255, 255)
                    .Bold = True
                End With
              
               End With
              
              
              
               For I = 1 To 6
               IndxAdrs = ShtName & "!" & .Cells(5, I).Resize(55, 1).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(50, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               Next
              
               IndxAdrs = ShtName & "!" & .Cells(2, 7).Resize(1, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(50, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",1,MOD(" & Replace(AggFuctn, "$A$2:A2", K) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               IndxAdrs = ShtName & "!" & .Cells(5, 7).Resize(55, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
              
               With .Cells(2, I + 1).Resize(50, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),MOD(" & Replace(AggFuctn, "$A$2:A2", .Cells(2, I + 1).Address(True, True) & ":" & .Cells(2, I + 1).Address(0, 0)) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
            ''''''''''''''''''
            With .Range("G5:J7").Offset(-3, -6).Resize(50, 8)
            Cll1 = .Cells(1, 1).Address(0, 1)
            .Cells.FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
                "=AND($A2<>"""",MOD(ROW($A2),2)<>0)"
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 15586489
                .TintAndShade = 0
            End With
            .FormatConditions(1).StopIfTrue = False
            End With
            
            .Tab.Color = RGB(255, 0, 0)
        End With
        WS1.Activate
        .Save
        End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        File2Name = "WRKBOOK 2.xlsx"
        FullName = Path & File2Name
            
            On Error Resume Next
            Set EWB = Application.Workbooks(File2Name)
            If EWB Is Nothing Then
                If Dir(FullName) <> "" Then Kill FullName
                         Kill FullName
        
                Set WB2 = Workbooks.Add
            Else
            EWB.Close False
                If Dir(FullName) <> "" Then Kill FullName
                 Kill FullName
                Set WB2 = Workbooks.Add
            End If
            On Error GoTo 0
    
    With WB2

    .SaveAs Filename:=FullName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Set WS3 = .Worksheets("Sheet1")
    
        With WS3
        ShtName = "'[" & WB1.Name & "]" & WS3.Name & "'"
               RWcLRngAdrs = WS1.Range("G5:J7").Address(True, True)
              
               With .Cells(1, 1).Resize(1, 8)
               .Value = [{"LINE","DIGIT","NOM","TYPE","STATE","ZONE","DIR","QTY*"}]
                With .Interior
                    .Pattern = xlSolid
                    .Color = RGB(37, 97, 149)
                    .TintAndShade = 0
                End With
                With .Font
                    .Color = RGB(255, 255, 255)
                    .Bold = True
                End With
              
               End With
              
               AggFuctn = "AGGREGATE(15,6,((COLUMN(" & ShtName & "!" & RWcLRngAdrs & ")-COLUMN(" & ShtName & "!$G$5))+((ROW(" & ShtName & "!" & RWcLRngAdrs & ")-ROW(" & ShtName & "!$G$5))*COLUMNS(" & ShtName & "!" & RWcLRngAdrs & ")+1))/--(" & ShtName & "!" & RWcLRngAdrs & "<>0),ROWS($A$2:A2))"
              
               For I = 1 To 6
               IndxAdrs = ShtName & "!" & .Cells(5, I).Resize(55, 1).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(50, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               Next
              
               IndxAdrs = ShtName & "!" & .Cells(2, 7).Resize(1, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(50, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",1,MOD(" & Replace(AggFuctn, "$A$2:A2", K) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               IndxAdrs = ShtName & "!" & .Cells(5, 7).Resize(55, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
              
               With .Cells(2, I + 1).Resize(50, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),MOD(" & Replace(AggFuctn, "$A$2:A2", .Cells(2, I + 1).Address(True, True) & ":" & .Cells(2, I + 1).Address(0, 0)) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
        '''''''''''''''''''''''''''
            With .Range("G5:J7").Offset(-3, -6).Resize(50, 8)
            Cll1 = .Cells(1, 1).Address(0, 1)
            .Cells.FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
                "=AND($A2<>"""",MOD(ROW($A2),2)<>0)"
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 15586489
                .TintAndShade = 0
            End With
            .FormatConditions(1).StopIfTrue = False
            End With
        
        End With
    
    End With

End Sub
 
Upvote 0
Coreection

Code: 
Public Sub Row_Col()
    Dim WB1 As Workbook, WB2 As Workbook, EWB As Workbook
    Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
    Dim Path As String
    Path = Environ("USERPROFILE") & "\Desktop\"
    RW = 50
        File1Name = "WRKBOOK 1.xlsx"
        FullName = Path & File1Name
            
            On Error Resume Next
            Set EWB = Application.Workbooks(File1Name)
            If EWB Is Nothing Then
                If Dir(FullName) <> "" Then Kill FullName
                         Kill FullName
        
                Set WB1 = Workbooks.Add
            Else
            EWB.Close False
                If Dir(FullName) <> "" Then Kill FullName
                 Kill FullName
                Set WB1 = Workbooks.Add
            End If
            On Error GoTo 0
    
    With WB1
    
            .SaveAs Filename:=FullName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    
        TxT = "EXAMPLE,EXAMPLE,EXAMPLE,EXAMPLE,EXAMPLE,EXAMPLE,code1,code2,code3,code4" & _
              ";,,,TYPE,state,ZONE,abs1,resp,ems,DOA" & _
              ";LINE,DIGIT,NOM,Auto,Auto,Auto,QTY,QTY,QTY,QTY" & _
              ";,,,,,,,,," & _
              ";1,11111,Smith,tea,BC,red,2,,9," & _
              ";2,44444,Drumph,snod,DE,orange,,,1," & _
              ";3,56789,Chuck,dok,ZA,blue,1,2,3,5"
        Set WS1 = .Worksheets("Sheet1")
        With WS1
        
            Arr = Split(TxT, ";")
            For x = LBound(Arr) To UBound(Arr)
            .Range("A" & x + 1 & ":J" & x + 1) = (Split(Arr(x), ","))
            Next
        
        Set WS2 = Sheets.Add(After:=.Parent.Worksheets(.Name))
        
        End With
        With WS2
                ShtName = WS1.Name

               RWcLRngAdrs = WS1.Range("G5:J" & RW).Address(True, True)
              
               AggFuctn = "AGGREGATE(15,6,((COLUMN(" & ShtName & "!" & RWcLRngAdrs & ")-COLUMN(" & ShtName & "!$G$5))+((ROW(" & ShtName & "!" & RWcLRngAdrs & ")-ROW(" & ShtName & "!$G$5))*COLUMNS(" & ShtName & "!" & RWcLRngAdrs & ")+1))/--(" & ShtName & "!" & RWcLRngAdrs & "<>0),ROWS($A$2:A2))"
              
               With .Cells(1, 1).Resize(1, 8)
               .Value = [{"LINE","DIGIT","NOM","TYPE","STATE","ZONE","DIR","QTY*"}]
                With .Interior
                    .Pattern = xlSolid
                    .Color = RGB(37, 97, 149)
                    .TintAndShade = 0
                End With
                With .Font
                    .Color = RGB(255, 255, 255)
                    .Bold = True
                End With
              
               End With
              
              
              
               For I = 1 To 6
               IndxAdrs = ShtName & "!" & .Cells(5, I).Resize(RW, 1).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(RW, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               Next
              
               IndxAdrs = ShtName & "!" & .Cells(2, 7).Resize(1, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(RW, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",1,MOD(" & Replace(AggFuctn, "$A$2:A2", K) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               IndxAdrs = ShtName & "!" & .Cells(5, 7).Resize(RW + 5, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
              
               With .Cells(2, I + 1).Resize(RW, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),MOD(" & Replace(AggFuctn, "$A$2:A2", .Cells(2, I + 1).Address(True, True) & ":" & .Cells(2, I + 1).Address(0, 0)) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
            ''''''''''''''''''
            With .Range("G5:J" & RW).Offset(-3, -6).Resize(RW, 8)
            Cll1 = .Cells(1, 1).Address(0, 1)
            .Cells.FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
                "=AND($A2<>"""",MOD(ROW($A2),2)<>0)"
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 15586489
                .TintAndShade = 0
            End With
            .FormatConditions(1).StopIfTrue = False
            End With
            
            .Tab.Color = RGB(255, 0, 0)
        End With
        WS1.Activate
        .Save
        End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        File2Name = "WRKBOOK 2.xlsx"
        FullName = Path & File2Name
            
            On Error Resume Next
            Set EWB = Application.Workbooks(File2Name)
            If EWB Is Nothing Then
                If Dir(FullName) <> "" Then Kill FullName
                         Kill FullName
        
                Set WB2 = Workbooks.Add
            Else
            EWB.Close False
                If Dir(FullName) <> "" Then Kill FullName
                 Kill FullName
                Set WB2 = Workbooks.Add
            End If
            On Error GoTo 0
    
    With WB2

    .SaveAs Filename:=FullName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Set WS3 = .Worksheets("Sheet1")
    
        With WS3
        ShtName = "'[" & WB1.Name & "]" & WS3.Name & "'"
               RWcLRngAdrs = WS1.Range("G5:J" & RW).Address(True, True)
              
               With .Cells(1, 1).Resize(1, 8)
               .Value = [{"LINE","DIGIT","NOM","TYPE","STATE","ZONE","DIR","QTY*"}]
                With .Interior
                    .Pattern = xlSolid
                    .Color = RGB(37, 97, 149)
                    .TintAndShade = 0
                End With
                With .Font
                    .Color = RGB(255, 255, 255)
                    .Bold = True
                End With
              
               End With
              
               AggFuctn = "AGGREGATE(15,6,((COLUMN(" & ShtName & "!" & RWcLRngAdrs & ")-COLUMN(" & ShtName & "!$G$5))+((ROW(" & ShtName & "!" & RWcLRngAdrs & ")-ROW(" & ShtName & "!$G$5))*COLUMNS(" & ShtName & "!" & RWcLRngAdrs & ")+1))/--(" & ShtName & "!" & RWcLRngAdrs & "<>0),ROWS($A$2:A2))"
              
               For I = 1 To 6
               IndxAdrs = ShtName & "!" & .Cells(5, I).Resize(RW + 5, 1).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(RW, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               Next
              
               IndxAdrs = ShtName & "!" & .Cells(2, 7).Resize(1, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
               With .Cells(2, I).Resize(RW, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",1,MOD(" & Replace(AggFuctn, "$A$2:A2", K) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
               IndxAdrs = ShtName & "!" & .Cells(5, 7).Resize(RW + 5, 4).Address(True, True)
               K = .Cells(2, I).Address(True, True) & ":" & .Cells(2, I).Address(0, 0)
              
               With .Cells(2, I + 1).Resize(RW, 1)
               .Formula = "=IFERROR(INDEX(" & IndxAdrs & ",CEILING(" & Replace(AggFuctn, "$A$2:A2", K) & ",COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))/COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "),MOD(" & Replace(AggFuctn, "$A$2:A2", .Cells(2, I + 1).Address(True, True) & ":" & .Cells(2, I + 1).Address(0, 0)) & "-1,COLUMNS(" & ShtName & "!" & RWcLRngAdrs & "))+1),"""")"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               End With
        '''''''''''''''''''''''''''
            With .Range("G5:J" & RW).Offset(-3, -6).Resize(RW, 8)
            Cll1 = .Cells(1, 1).Address(0, 1)
            .Cells.FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
                "=AND($A2<>"""",MOD(ROW($A2),2)<>0)"
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 15586489
                .TintAndShade = 0
            End With
            .FormatConditions(1).StopIfTrue = False
            End With
        
        End With
    
    End With

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

X
  • Question Question
VBA for extracting specific data from PDF Docs
Replies
3
Views
607
xcellrodeo
X
U
  • Solved
Need help with VBA coding If and ElseIf statements
Replies
6
Views
293
dreid1011
dreid1011
Y
  • Question Question
VBA Code to activate the tab and and transfer data
Replies
1
Views
222
Joe4
Joe4
I
  • Solved
FILTER formula criteria based of a variable with VBA
Replies
2
Views
246
ItalianPlatinum
I
M
  • Question Question
Delete rows that doe not match
Replies
1
Views
235
Joe4
Joe4

Forum statistics

Threads
1,223,247
Messages
6,171,004
Members
452,374
Latest member
keccles

Share this page

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