Formatting Cells and Values

jakjo
Lounger
Posts: 25
Joined: 28 May 2022, 00:57

Formatting Cells and Values

Post by jakjo »

Hello everyone
I have a task that I desperately need to complete, but I am having problem with three points and I am hoping you can help.
I have this code that works well to Copy specific ranges from vertical to horizontal From all closed workbooks to the workbook totals amounts
Here is a brief rundown of what I am attempting to do in two worksheet Total cash sales & Total Deferred Sales in the workbook totals amounts.

Code: Select all

Option Explicit
   Sub test()
     Dim tt$, rb(1 To 2), a, b, c, ws As Worksheet, mFile$
     Dim mRow(1 To 2) As Long, i%, d%, e%, mCol As Integer
     Application.ScreenUpdating = False: DoEvents

     tt = ThisWorkbook.Path & "\"
     rb(1) = "cash sales": rb(2) = "Deferred Sales"

       a = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count
       ReDim c(1 To a, 1 To 77)
       ReDim b(1 To 2)
       b(1) = c
       b(2) = c

      Set ws = Workbooks.Add.Sheets(1)
       mFile = Dir(tt & "*.xlsx")

        Do Until mFile = ""
        DoEvents
        For i = 1 To 2
        ws.Range("A1:D45") = "='" & tt & "[" & mFile & "]" & rb(i) & "'!A1"
        a = ws.Range("A1:D45").Value
         mRow(i) = 1 + mRow(i)
         b(i)(mRow(i), 1) = a(1, 1)
         mCol = 1
    
       For d = 1 To 3 Step 2
      For e = 3 To 45
        If a(e, d) <> 0 Then
          mCol = 1 + mCol
          If a(e, d + 1) <> "" And a(e, d + 1) <> 0 Then b(i)(mRow(i), mCol) = a(e, d + 1)
        End If
      Next
    Next
  Next
    mFile = Dir
   Loop
     ws.Parent.Close False
       For i = 1 To 2
      With Sheets(i).Range("A1").CurrentRegion
       .Offset(1).Delete xlShiftUp
       .Offset(1).Resize(mRow(i)) = b(i)
       .Offset(1 + mRow(i)) = "=Sum(R2C:R[-1]C)"
        .Offset(1 + mRow(i))(1) = "FINAL TOTAL"
         End With
        Next
        End
     End Sub
1) I need to Customize some formatting for rows height to 25 points, font type, font size, number format, and columns width.
2) I need to change the row height for that contains "Final Total" to 60 points.
3) Last point if possible I need to include the borders in two worksheet Total cash sales & Total Deferred Sales
How can These points is included with this code referred to above ... Thank you for your assistance in this
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Formatting Cells and Values

Post by HansV »

1) Please specify the details.
2) Below the line

Code: Select all

            .Offset(1 + mRow(i))(1) = "FINAL TOTAL"
insert

Code: Select all

            .Offset(1 + mRow(i))(1).EntireRow.Height = 60
3) Where do you want borders?
Best wishes,
Hans

jakjo
Lounger
Posts: 25
Joined: 28 May 2022, 00:57

Re: Formatting Cells and Values

Post by jakjo »

Thank you so much Hans, I tried to run this and I get a run-time error "1004"
for more details I put the result in two worksheet Total cash sales & Total Deferred Sales
Please see the attachment for a sample of the data and the desired output ... Thanks in advance for any help you can provide.
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Formatting Cells and Values

Post by HansV »

Sorry about that. Here is a new version of the entire macro:

Code: Select all

Sub test()
    Dim tt$, rb(1 To 2), a, b, c, ws As Worksheet, mFile$
    Dim mRow(1 To 2) As Long, i%, d%, e%, mCol As Integer

    Application.ScreenUpdating = False
    DoEvents

    tt = ThisWorkbook.Path & "\"
    rb(1) = "cash sales"
    rb(2) = "Deferred Sales"

    a = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count
    ReDim c(1 To a, 1 To 77)
    ReDim b(1 To 2)
    b(1) = c
    b(2) = c

    Set ws = Workbooks.Add.Sheets(1)
    mFile = Dir(tt & "*.xlsx")

    Do Until mFile = ""
        DoEvents
        For i = 1 To 2
            ws.Range("A1:D45") = "='" & tt & "[" & mFile & "]" & rb(i) & "'!A1"
            a = ws.Range("A1:D45").Value
            mRow(i) = 1 + mRow(i)
            b(i)(mRow(i), 1) = a(1, 1)
            mCol = 1
            For d = 1 To 3 Step 2
                For e = 3 To 45
                    If a(e, d) <> 0 Then
                        mCol = 1 + mCol
                        If a(e, d + 1) <> "" And a(e, d + 1) <> 0 Then
                            b(i)(mRow(i), mCol) = a(e, d + 1)
                        End If
                    End If
                Next e
            Next d
        Next i
        mFile = Dir
    Loop
    ws.Parent.Close False
    For i = 1 To 2
        With Sheets(i).Range("A1").CurrentRegion
            .Offset(1).Delete xlShiftUp
            .Offset(1).Resize(mRow(i)) = b(i)
            .Offset(1 + mRow(i)).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            .Offset(1 + mRow(i))(1) = "FINAL TOTAL"
        End With
        With Sheets(i).Range("A1").CurrentRegion
            .NumberFormat = "0.00"
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
            .Font.Name = "Cambria"
            .Font.Size = 14
            .Rows(1).Font.Size = 12
            .Rows(.Rows.Count).Font.Size = 16
            .Range("B1:AH1,AH2:AH" & .Rows.Count).Interior.Color = &HC4D9DD
            .Range("AI1:BY1,BX2:BY" & .Rows.Count).Interior.Color = &HD9D9D9
            .Borders.LineStyle = xlContinuous
            .RowHeight = 25
            .Rows(1).RowHeight = 40
            .Rows(.Rows.Count).RowHeight = 60
            .EntireColumn.AutoFit
        End With
    Next i

    Application.ScreenUpdating = True
End Sub[/coe]
Best wishes,
Hans

jakjo
Lounger
Posts: 25
Joined: 28 May 2022, 00:57

Re: Formatting Cells and Values

Post by jakjo »

don't apologize Hans
Excellent and so easy for you ... I didn't think of it at all
That's perfect and awesome now. Thank you very much for great help and thanks a lot for your patience.
Best Regards