Posts by rollis13
-
-
Thanks for the positive feedback, glad having been of some help.
-
-
-
-
You're welcome .
-
Sorry, but this time it's better to start a new thread, the title of this one has nothing to do with this last request.
-
My suggestion without knowing any thing about you project:
With the help of your Function, before updating column B I would copy the old data from column B into a hidden helper column (maybe somewhere in the sheet, in your example lets say column H) and only then update column B. With a formula in column C compare new data in column B against old data in the hidden column. Formula for column C:
=IF(B7<>H7,"Delta","")
If you can't make any changes to your Function just have the copy of the old data done by the macro you have showen above.
-
-
-
That's because you are activating the sheets Sheet(ws(i)).Activate to fetch the data and the last activated sheet will be the last of the ws Array so it's the "3. ...". It isn't necessary to activate a sheet to fetch data from it; just give the right reference to the ranges used.
Now, first of all get rid of the trailing spaces in the sheet names, they only create confusion since they aren't visible.
Then try this:
Code
Display MoreOption Explicit Sub BuildInvoiceAll() Dim ws As Variant, sht As Variant Dim i As Long, lr As Long, nr As Long, c As Long Dim cell As Range Application.ScreenUpdating = False ' Set array of worksheet names to copy from ws = Array("1.Power Distribution - Dimmer", "2.POWER CABLES - ADAPTORS", "3.CABLES (OTHER) - CABLE CROSS") ' Array of columns to check sht = Array("D") nr = 15 Sheets("PROFORMA DRYHIRE").Range("A15:C70").ClearContents ' Loop through all sheets in sheets array For i = LBound(ws) To UBound(ws) ' Loop through all columns in the column array For c = LBound(sht) To UBound(sht) ' Find last row in column with data With Sheets(ws(i)) lr = .Cells(Rows.Count, sht(c)).End(xlUp).Row ' Loop through all cells in column For Each cell In .Range(.Cells(1, sht(c)), .Cells(lr, sht(c))) ' Check to see if value is numeric and not 0 If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then ' Copy cells C, D, E to columns A, B, C of main sheet Range(.Cells(cell.Row, "C"), .Cells(cell.Row, "E")).Copy Sheets("PROFORMA DRYHIRE").Cells(nr, "A").PasteSpecial Paste:=xlPasteValues ' Increment nr counter nr = nr + 1 ' Check to see if rows are full If nr > 70 Then MsgBox "Rows are full" Exit Sub End If End If Next cell End With Next c Next i Application.ScreenUpdating = True MsgBox "Macro complete - Data Stored!" End Sub
-
Do you mean that every sheet has to create it's own template ? Just get rid of the ws Array and the cycle For i.
Just set a variable (ws) to read the name of the sheet from which you launch the macro.
Also I would close the template just after saving it if you don't need it straight away (see note in macro).
Code
Display MoreOption Explicit Sub BuildTemplateINm() Dim nr As Long Dim cell As Variant Dim lr As Long Dim N$ Dim ws As String ws = ActiveSheet.Name Application.ScreenUpdating = False Application.DisplayAlerts = False ' Loop through all sheets in sheets array Sheets.Add.Name = "NewSheet" Range("A1").Value = "Description" Range("B1").Value = "Quantity" nr = 2 With Sheets(ws) ' Find last row in column with data lr = .Cells(Rows.Count, "D").End(xlUp).Row ' Loop through all cells in column For Each cell In .Range(.Cells(1, "D"), .Cells(lr, "D")) ' Check to see if value is numeric and not 0 If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then ' Copy cells C, D, E to columns A, B, C of newsheet .Range(.Cells(cell.Row, "C"), .Cells(cell.Row, "E")).Copy Sheets("NewSheet").Cells(nr, "A").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False ' Increment nr counter nr = nr + 1 End If Next cell End With ' Name and Save newsheet N = ActiveWorkbook.Path & "\" & ws & ".xlsx" Sheets("NewSheet").Move ActiveWorkbook.SaveAs N, 51 ActiveWorkbook.Close '<- delete if you need the new template open Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "Done! " & ws & " template created." End Sub
-
There was an extra space at the end of sheet "3. ...." too.
Yes, if the macro gets interrupted you need to manually delete the "Newsheet" but you could implement, at the beginning of the macro, a check if there already is a sheet named Newsheet and delete it before proceeding. But this can only happen while testing, once the macro is definitve this should no longer occur.
-
Also done some cleaning out, have a try:
Code
Display MoreOption Explicit Sub BuildTemplateINm() Dim i As Long, nr As Long Dim cell As Variant Dim ws As Variant, lr As Long Dim wkb As Workbook Dim N$ Set wkb = ActiveWorkbook Application.ScreenUpdating = False Application.DisplayAlerts = False ws = Array("1.Power Distribution - Dimmer", "2.POWER CABLES - ADAPTORS", "3.CABLES (OTHER) - CABLE CROSS") ' Loop through all sheets in sheets array For i = LBound(ws) To UBound(ws) wkb.Sheets(ws(i)).Activate Sheets.Add.Name = "NewSheet" Range("A1").Value = "Description" Range("B1").Value = "Quantity" nr = 2 Sheets(ws(i)).Activate ' Find last row in column with data lr = Cells(Rows.Count, "D").End(xlUp).Row ' Loop through all cells in column For Each cell In Sheets(ws(i)).Range(Cells(1, "D"), Cells(lr, "D")) ' Check to see if value is numeric and not 0 If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then ' Copy cells C, D, E to columns A, B, C of newsheet Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy Sheets("NewSheet").Cells(nr, "A").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False ' Increment nr counter nr = nr + 1 End If Next cell N = ActiveWorkbook.Path & "\" & ws(i) & ".xlsx" Sheets("NewSheet").Move ActiveWorkbook.SaveAs N, 51 Next i Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "Done!" End Sub
-
'Loop through all sheets in sheets array
For i = LBound(ws) To UBound(ws)Here you are looping through all the sheets but the loop ends before the code that saves the new file. That means that the new file will always contain copy of all the sheets. Move the line Next i to the end of the macro and move the lines Set shtName = ActiveSheet and nr = 2 just inside the For i loop.
Leave it to you to spot/fix any other issues (probably there won't be any).
-
-
-
Thanks for the positive feedback, glad having been of some help.
-
As said it would be static since the name of the sheet is hardcode and was already in your macro, here:
For Each cell In Worksheets("1.Power Distribution - Dimmer").Range("D5:D9, ...
How will the macro work with other sheet names ?
So, all you have to do is create a new variable (example: shtName) at the beginning and assign to it the name of the active sheet to be used here in the For/Each and later down in the macro when you assign to the variable N the path and the name of the file to be saved.
Maybe:
Code
Display MoreSub BuildTemplateINm() Dim i As Long, j As Long, nr As Long Dim cell As Variant, f As Range Dim Descript As String Dim shtName As Worksheet '<- added Set shtName = ActiveSheet '<- added Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets.Add.Name = "NewSheet" Worksheets("NewSheet").Range("A1").Value = "Description" Worksheets("NewSheet").Range("B1").Value = "Quantity" nr = 1 Sheets("NewSheet").Range("A2:B150").ClearContents For Each cell In Worksheets(shtName.Name).Range("D5:D9, D11:D20, D22:D32, D34:D46, D48:D53, D55:D62, D64:D71, D73:D84, D86:D97") '<- changed If cell > 0 Then Descript = cell.Offset(0, -1) With Sheets("NewSheet") Set f = .Range("A2:A150").Find(Descript, , xlValues, xlWhole) If Not f Is Nothing Then nr = f.Row Else nr = nr + 1 If nr > 150 Then MsgBox "Rows are full" Exit Sub End If End If .Cells(nr, "A") = Descript .Cells(nr, "B") = cell End With End If Next cell Application.ScreenUpdating = False Const S = "NewSheet" Dim N$ N = ActiveWorkbook.Path & "\" & shtName.Name & ".xlsx" '<- changed Sheets(S).Move Application.DisplayAlerts = False ActiveWorkbook.SaveAs N, 51 Application.DisplayAlerts = True End Sub
-