Posts by KjBox
-
-
-
Try
Code
Display MoreSub 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
-
My bad! Try changing the code in the Standard Module to this
Code
Display MoreSub 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
-
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
CodePrivate 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
Display MoreSub 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
-
I have a solution for you.
I will PM you with my PayPal details and post the code here on receipt of payment.
-
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?
-
I can look at this for you
-
-
- Use this modified code to copy columns A, B & C from Foglio2 to Foglio1 when a match is found. I have added comments to help you understand the code.
- Mid(y(i, 1), 2, 13) The Mid function has 3 elements: String of Characters, Starting point, Number of Characters. So, y(i, 1) is the string, 2 is the starting point (first character is ignored), 13 is the number of characters to return from the starting point onwards.
- Application.Match(Mid(y(i, 1), 2, 13), x, 0) VBA does not have a Match function so the "Application." bit tells the code to use the worksheet function MATCH, which has 3 elements: String to match, Array to search for a match, Exact or close match. So, Mid(y(i, 1), 2, 13) is the string that is to be matched, x is the array to search and 0 is "search for exact match"
Code
Display MoreOption Explicit Sub MatchCopy() Dim x, y, z, i&, ii& ' Load arrays x & y (x with just column A of Foglio1, y with all data from Foglio2) x = Foglio1.Cells(1).CurrentRegion.Columns(1) y = Foglio2.Cells(1).CurrentRegion ' Redim z to hold all matching data (the -1 is to ignore the column header) ReDim z(1 To UBound(x, 1) - 1, 1 To 3) ' Loop through array x to remove first character and keep next 13 characters from each entry For i = 2 To UBound(x, 1) x(i, 1) = Mid(x(i, 1), 2, 13) Next ' Loop through array y and check for match of the same 13 characters in Column A with array x For i = 2 To UBound(y, 1) If Not IsError(Application.Match(Mid(y(i, 1), 2, 13), x, 0)) Then ' If match found then load array z, in the appropriate row, with data from columns A, B & C of array y ii = Application.Match(Mid(y(i, 1), 2, 13), x, 0) z(ii - 1, 1) = y(i, 1): z(ii - 1, 2) = y(i, 2): z(ii - 1, 3) = y(i, 3) End If Next ' Place the contents of array z onto Foglio1 in columns D, E & F Foglio1.Cells(2, 4).Resize(UBound(z, 1), 3) = z ' Adjust the width of Foglio1 column D & E to suit added data Foglio1.Columns(4).Resize(, 2).AutoFit End Sub
The code is faster because it is an "array based" code as opposed to an "object based" code.
An array based code first loads all required data into arrays, those arrays can then be manipulated and/or modified within the machine memory before place modifications back to a worksheet.
An object based code has to constantly refer back to a worksheet to place data and update, then pick up the next bit of data to check.
The array based code refers to a worksheet just once to get data and once to place data, hence much faster.
-
This will be faster, especially for thousands of rows of data
Code
Display MoreOption Explicit Sub Compare() Dim x, y, z, i&, ii& x = Foglio1.Cells(1).CurrentRegion.Columns(1) y = Foglio2.Cells(1).CurrentRegion.Columns(1) ReDim z(1 To UBound(x, 1) - 1, 1 To 1) For i = 2 To UBound(x, 1) x(i, 1) = Mid(x(i, 1), 2, 13) Next For i = 2 To UBound(y, 1) If Not IsError(Application.Match(Mid(y(i, 1), 2, 13), x, 0)) Then ii = Application.Match(Mid(y(i, 1), 2, 13), x, 0) z(ii - 1, 1) = y(i, 1) End If Next Foglio1.Cells(2, 4).Resize(UBound(z, 1)) = z End Sub
-
Quote
and if match found it should copy the row starting cell D sheet 1 (so adjacent to the main item code matching).
Do you mean, when a match is found, you want to copy from Sheet1 column D onwards from to Sheet2 column D onwards in the matching Row?
Your sample file has no data in Column D onwards
-
Rather than an image, with which we cannot work, can you please attach your actual mini mocked up spreadsheet.
Any cells that normally contain text or data fill with anything.
-
Maybe
-
-
Maybe:
Code
Display MoreSub CollectData() Dim fso As Object, xlFile As Object Dim sFolder$ Dim r&, j&, k&, i&, d# Const s$ = "value" 'Change to actual header required '* Sheets("Check").Activate Range("F8:I50").ClearContents Range("A8:D50").Copy Range("F8") Range("A8:D50").ClearContents '* With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .InitialFileName = ThisWorkbook.Path If .Show Then sFolder = .SelectedItems(1) Else Exit Sub End With Set fso = CreateObject("Scripting.FileSystemObject") For Each xlFile In fso.GetFolder(sFolder).Files With Workbooks.Open(xlFile.Path, Password:="password") With .Sheets(1) j = .Cells(.Rows.Count, 1).End(xlUp).Row k = .Cells(1, Sheet1.Columns.Count).End(xlToLeft).Column i = Application.Match(s, .Rows(1), 0) d = Application.Sum(.Cells(1).CurrentRegion.Columns(i)) End With .Close False End With r = r + 1 Cells(r + 7, 1).Value = xlFile.Name Cells(r + 7, 2).Value = j Cells(r + 7, 3).Value = k Cells(r + 7, 4).Value = d ActiveWorkbook.Save Next End Sub
-
Try the attached file, I have amended the code assigned to the button to:
Code
Display MoreSub Hotlist() Dim x, y, i&, ii&, iii& x = Sheets("Raw Data").Cells(1).CurrentRegion ReDim y(1 To UBound(x, 1), 1 To 12) For i = 2 To UBound(x, 1) If (x(i, 5) <= 10 Or x(i, 6) <= 10) _ And (x(i, 4) <> 0 And x(i, 5) <> 0 And x(i, 6) <> O) Then ii = ii + 1 For iii = 1 To 12 y(ii, iii) = x(i, iii) Next End If Next With Sheets("Hot List") .Rows(2).Resize(100000).Delete .Cells(2, 1).Resize(UBound(y, 1), 12) = y .Columns(4).Resize(, 6).NumberFormat = "#,###" .Columns(11).NumberFormat = "#,###" End With End Sub
-
Try the attached, click the button on Hot List Sheet. Any existing data will be cleared and new data added.
Code assigned to the button:
Code
Display MoreSub Hotlist() Dim x, y, i&, ii&, iii& x = Sheets("Raw Data").Cells(1).CurrentRegion ReDim y(1 To UBound(x, 1), 1 To 12) For i = 2 To UBound(x, 1) If x(i, 6) <= 10 Then ii = ii + 1 For iii = 1 To 12 y(ii, iii) = x(i, iii) Next End If Next With Sheets("Hot List") .Rows(2).Resize(100000).Delete .Cells(2, 1).Resize(UBound(y, 1), 12) = y .Columns(4).Resize(, 6).NumberFormat = "#,###" .Columns(11).NumberFormat = "#,###" End With End Sub
You will find the code runs much faster than the original, especially if data set is large
-
Do you want to remove any existing data on the Hot List sheet or add to any existing data?
-
Attach your workbook, it is impossible to say what is wrong without seeing the workbook structure and the ciode.