VBA required for Columns to rows

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
210
Office Version
  1. 2019
  2. 2010
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

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

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

C
  • Question
Comparing 3 tables to a list of numbers, if match, return 4 columns worth of data on another tab
Replies
4
Views
117
alansidman
A
T
  • Solved
MATCH function
2
Replies
14
Views
186
Fluff
Fluff
M
  • Question
Stack/Combine multiple columns into one column
Replies
4
Views
151
myall_blues
myall_blues
M
  • Question
VBA Code to copy rows by date from one tab to another / repeat based on new date
Replies
3
Views
253
kevin9999
K
E
  • Question
Estimating Spreadsheet-Summing
Replies
1
Views
164
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,467
Messages
6,124,984
Members
449,201
Latest member
Lunzwe73

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