need this macro, in cfs on hand report, changed as described. $20.00

steve400243 · May 20th 2022

I am having an issue with this report and would like some changes made. I would like the report to look like the attached example, CFS on Hand Report, after ran, with no borders lines between MAWBS, and no open Spaces. For your review here is the notes I have made. I have several files in a folder on my desktop like the 2 examples Ever Eagle, and OOCL. all files will have a different number of rows from 13 up to row 39. The other workbook “CFS On Hand” Is a report file. I want to place this file in the folder with the files and when a user selects it a message box come up asking if they want to create a new report. Selecting “YES” will activate the macro to open each file in the folder and look for a date in cell “H4” in each file. If no date in that cell, skip that file. If a date is in that cell, look for any cells that are blank in any row that has Data in G13 thru J39. And copy that Row, up to Column “P”, over to the Report File. Each file can have a different number of Rows with Data up to Row 39. In the 2 Example File it would skip the OOCL file as no Date in in Cell H4. But it would copy over row 15 in the Ever Eagle file as it has open cells in the rows with data, and has a Devan date in cell H4. Needed Results As shown in the example. After opening each file and running the macro it would save the report in the file as CFS ON HAND REPORT – and the current date. Please let me know if I need to make another post? Please see the notes below and let me know. Thank you.

steve400243 · May 20th 2022

10% paid via paypal to Ozgrid: 4T248943VP1080146

steve400243 · May 20th 2022

My Apologies, here is the code I have been using

Code

Sub ConsolidateData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Dim wb As Workbook, sh As Worksheet, ary As Variant, fPath As String, fName As String, i As Long, rw As Long
Dim LastSourceRow As Long, SourceCount As Long
Const FirstSourceRow = 13
fPath = ThisWorkbook.Path & Application.PathSeparator
Set sh = ThisWorkbook.Worksheets("Sheet1")
sh.UsedRange.Offset(2).Clear
ary = Array("C3", "C4", "C5", "H2", "H3", "H4")
fName = Dir(fPath & "*.xls*")
rw = sh.Cells(sh.Rows.Count, 8).End(xlUp).Row + 1
   Do While fName <> ""
      If fName <> ThisWorkbook.Name Then
         'If rw > 3 Then
          '  sh.Rows(2).Copy sh.Rows(rw)
           ' rw = rw + 1
         'End If
         Set wb = Workbooks.Open(fPath & fName)
         With wb.Sheets(1)
         
         If IsDate(.Range("H4")) Then
            For i = 2 To 7
               sh.Cells(rw, i) = .Range(ary(i - 2)).Value
            Next
            LastSourceRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            
            If LastSourceRow >= FirstSourceRow Then
               For cRow = FirstSourceRow To LastSourceRow
                  If Application.WorksheetFunction.CountBlank(.Range("G" & cRow & ":K" & cRow)) Then
                     sh.Range("H" & rw).Value = .Range("C" & cRow).Value
                     sh.Range("I" & rw).Value = .Range("D" & cRow).Value
                     sh.Range("J" & rw).Value = .Range("B" & cRow).Value
                     sh.Range("K" & rw).Value = .Range("A" & cRow).Value
                     sh.Range("L" & rw).Resize(1, 10).Value = .Range("G" & cRow).Resize(1, 10).Value
                     rw = rw + 1
                  End If
               Next
            End If
         End If
         End With
         wb.Close False
         Set wb = Nothing
        sh.Range("B" & rw - 1).Resize(1, 20).Borders(xlEdgeBottom).Weight = xlThin
      End If
      
      fName = Dir
    
   Loop
sh.Range("B" & 3).Resize(rw - 3, 5).Font.ColorIndex = 1
sh.Range("B" & 3).Resize(rw - 3, 5).Font.Bold = False
sh.Range("L" & 3).Resize(rw - 3, 4).Replace What:="", Replacement:="NOT RECEIVED", LookAt:=xlWhole
sh.Columns.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

Display More

**KjBox** · May 20th 2022

I can look at this for you

steve400243 · May 20th 2022

Excellent, Thank you Sir!

**KjBox** · May 20th 2022

When you create a Report do you want to clear any existing data in the Report File before adding new Report data, or add new data to any existing data?

steve400243 · May 20th 2022

I do a new report daily. So clearing the existing data in the main report file will work.

**KjBox** · May 20th 2022

I have a solution for you.

I will PM you with my PayPal details and post the code here on receipt of payment.

steve400243 · May 20th 2022

THANK YOU - Paypal sent - OHV86366T52962708

**KjBox** · May 20th 2022

Payment received, many thanks.

Make sure all the CFS files and the CFS Report file are in the same folder.

Put this in the ThisWorkbook Object module

Code

Private Sub Workbook_Open()
    If MsgBox("Do you want to create a new Report?", vbQuestion + vbYesNo, "Create Report") = vbYes Then CreateReport
End Sub

And in a standard module put this code

Code

Sub CreateReport()
    Dim x, y, i&, ii&, iii&, sPath$, sFile$
    sPath = ThisWorkbook.Path
    If Right(sPath, 1) <> Application.PathSeparator Then
        sPath = sPath & Application.PathSeparator
    End If
    sFile = Dir(sPath)
    ReDim x(1 To 20, 1 To 1)
    
    Application.ScreenUpdating = 0
    Do While Len(sFile) > 0
        If sFile <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(sPath & sFile)
            With wb.Sheets(1)
                If IsDate(.[h4]) Then
                    y = .[a12].CurrentRegion
                    For i = 2 To UBound(y, 1)
                        If y(i, 7) = "" Or y(i, 8) = "" _
                        Or y(i, 9) = "" Or y(i, 10) = "" Then
                            ii = ii + 1
                            ReDim Preserve x(1 To 20, 1 To ii)
                            x(1, ii) = .[c3]: x(2, ii) = .[c4]
                            x(3, ii) = .[c5]: x(4, ii) = .[h4]
                            For iii = 1 To 16
                                x(iii + 4, ii) = y(i, iii)
                            Next
                            For iii = 11 To 14
                                If x(iii, ii) = "" Then x(iii, ii) = "NOT RECEIVED"
                            Next
                        End If
                    Next
                End If
            End With
            wb.Close 0
        End If
        sFile = Dir
    Loop
    With ThisWorkbook.Sheets(1).ListObjects(1)
        .DataBodyRange.Offset(1).Clear
        .ListRows(1).Range.ClearContents
        .DataBodyRange.Resize(ii) = Application.Transpose(x)
        With .DataBodyRange
            For i = 1 To .Rows.Count
                For ii = 11 To 14
                    If .Rows(i).Columns(ii) = "NOT RECEIVED" Then
                        .Rows(i).Columns(ii).Interior.Color = vbRed
                        .Rows(i).Columns(ii).Font.Color = vbWhite
                    End If
                Next
            Next
        End With
        .Parent.Parent.Save
    End With
    
End Sub

Display More

steve400243 · May 20th 2022

Many Thanks, Looks to be returning more rows than needed? Please have a look

steve400243 · May 20th 2022

Here is the report how it should look. I ran it with some other test files. and manually deleted the unnecessary rows.

**KjBox** · May 20th 2022

My bad! Try changing the code in the Standard Module to this

Code

Sub CreateReport()
    Dim x, y, i&, ii&, iii&, iv&, sPath$, sFile$
    sPath = ThisWorkbook.Path
    If Right(sPath, 1) <> Application.PathSeparator Then
        sPath = sPath & Application.PathSeparator
    End If
    sFile = Dir(sPath)
    ReDim x(1 To 20, 1 To 1)
    
    Application.ScreenUpdating = 0
    Do While Len(sFile) > 0
        If sFile <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(sPath & sFile)
            With wb.Sheets(1)
                If IsDate(.[h4]) Then
                    y = .[a12].CurrentRegion
                    For i = 2 To UBound(y, 1)
                        iv = 0
                        For iii = 7 To 10
                            If y(i, iii) = vbNullString Then iv = iv + 1
                        Next
                        If iv > 0 And iv < 4 Then
                            ii = ii + 1
                            ReDim Preserve x(1 To 20, 1 To ii)
                            x(1, ii) = .[c3]: x(2, ii) = .[c4]
                            x(3, ii) = .[c5]: x(4, ii) = .[h4]
                            For iii = 1 To 16
                                x(iii + 4, ii) = y(i, iii)
                            Next
                            For iii = 11 To 14
                                If x(iii, ii) = "" Then x(iii, ii) = "NOT RECEIVED"
                            Next
                        End If
                    Next
                End If
            End With
            wb.Close 0
        End If
        sFile = Dir
    Loop
    With ThisWorkbook.Sheets(1).ListObjects(1)
        .DataBodyRange.Offset(1).Clear
        .ListRows(1).Range.ClearContents
        .DataBodyRange.Resize(ii) = Application.Transpose(x)
        With .DataBodyRange
            For i = 1 To .Rows.Count
                For ii = 11 To 14
                    If .Rows(i).Columns(ii) = "NOT RECEIVED" Then
                        .Rows(i).Columns(ii).Interior.Color = vbRed
                        .Rows(i).Columns(ii).Font.Color = vbWhite
                    End If
                Next
            Next
        End With
        .Parent.Parent.Save
    End With
    
End Sub

Display More

steve400243 · May 21st 2022

Almost there. It is including a total row under each Row that is not needed.

**KjBox** · May 21st 2022

Try

Code

Sub CreateReport()
    Dim x, y, i&, ii&, iii&, iv&, sPath$, sFile$
    sPath = ThisWorkbook.Path
    If Right(sPath, 1) <> Application.PathSeparator Then
        sPath = sPath & Application.PathSeparator
    End If
    sFile = Dir(sPath)
    ReDim x(1 To 20, 1 To 1)
    
    Application.ScreenUpdating = 0
    Do While Len(sFile) > 0
        If sFile <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(sPath & sFile)
            With wb.Sheets(1)
                If IsDate(.[h4]) Then
                    y = .[a12].CurrentRegion
                    For i = 2 To UBound(y, 1) - 1
                        iv = 0
                        For iii = 7 To 10
                            If y(i, iii) = vbNullString Then iv = iv + 1
                        Next
                        If iv > 0 And iv < 4 Then
                            ii = ii + 1
                            ReDim Preserve x(1 To 20, 1 To ii)
                            x(1, ii) = .[c3]: x(2, ii) = .[c4]
                            x(3, ii) = .[c5]: x(4, ii) = .[h4]
                            For iii = 1 To 16
                                x(iii + 4, ii) = y(i, iii)
                            Next
                            For iii = 11 To 14
                                If x(iii, ii) = "" Then x(iii, ii) = "NOT RECEIVED"
                            Next
                        End If
                    Next
                End If
            End With
            wb.Close 0
        End If
        sFile = Dir
    Loop
    With ThisWorkbook.Sheets(1).ListObjects(1)
        .DataBodyRange.Offset(1).Clear
        With .ListRows(1).Range
            .ClearContents
            .Interior.Color = xlNone
            .Font.Color = xlAutomatic
        End With
        .DataBodyRange.Resize(ii) = Application.Transpose(x)
        With .DataBodyRange
            For i = 1 To .Rows.Count
                For ii = 11 To 14
                    If .Rows(i).Columns(ii) = "NOT RECEIVED" Then
                        .Rows(i).Columns(ii).Interior.Color = vbRed
                        .Rows(i).Columns(ii).Font.Color = vbWhite
                    End If
                Next
            Next
        End With
        .Parent.Parent.Save
    End With
    
End Sub

Display More

steve400243 · May 21st 2022

That looks like the winner! I will continue to test for a bit more today, and on Monday. Have a nice weekend. Appreciate the quick work.

**KjBox** · May 21st 2022

You're welcome

need this macro, in cfs on hand report, changed as described. $20.00

Participate now!

Share

Users Viewing This Thread