Code below - copy the last 2 rows data of each workbook files in a folder then paste it all to Master workbook.
Problem 1 - can someone help on how get the codes below copy only the last row of each workbook.
Problem 2 - instead of copying from Col A to last Column of Data, I want to copy only specific columns e.g. Columns A to F, J and M.
Appreciate any help thanks.
Option Explicit
Sub OpenEachFiles_CopyLastRow_PasteToMaster()
Dim fso, fldr, fName As Object, Cnt, Cnt2, Cnt3, Cnt4, lRow, lCol As Long
Dim ws As Worksheet, rngArray() As Variant, rng As Range
On Error GoTo Errorfix
Cnt2 = 1 'dimension array
Cnt3 = 0 'array positions
Set fso = CreateObject("scripting.filesystemobject")
Set fldr = fso.GetFolder("C:\Users\Tope\Desktop\Data")
For Each fName In fldr.files
If fName.Name Like "*.xls*" Then
Workbooks.Open Filename:=fName
For Each ws In Workbooks(fName.Name).Sheets
If LCase(ws.Name) = LCase("Data") Then
With Sheets("Data")
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(lRow, .Columns.Count).End(xlToLeft).Column
End With
Cnt2 = Cnt2 + 1
ReDim Preserve rngArray(Cnt2)
With Workbooks(fName.Name).Sheets(ws.Name)
Set rng = .Range(.Cells(lRow - 1, 1), .Cells(lRow, lCol))
End With
rngArray(Cnt3) = rng
Cnt3 = Cnt3 + 1
End If
Next ws
Workbooks(fName.Name).Close SaveChanges:=False
End If
Next fName
Cnt = 2
For Cnt4 = 0 To Cnt3 - 1
With ThisWorkbook.Sheets("Master")
.Range(.Cells(Cnt, "A"), .Cells(Cnt + 1, lCol)) = rngArray(Cnt4)
End With
Cnt = Cnt + 2
Next Cnt4
Errorfix:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Error"
End If
Set fldr = Nothing
Set fso = Nothing
End Sub
Have script that stores an array and if it changes it finds the difference. Now I need it to take that difference and check against if the adjacent cell is "John or Mary" and times the array value difference by: (If "John" = Array Value Diff. * PO#1) OR (If "Mary" = Array Value Diff. * PO#2). This is the final value I need written to Sheet 1 which right now is just the Array Value Diff. value.
Code in Module 1
Public myArr()
Public Sub PopulateMyArr()
myArr = Sheet4.Range("I6:I500").Value
End Sub
Code in This Workbook
Private Sub Workbook_Open()
PopulateMyArr
End Sub
Code in Sheet4
Private Sub ToggleButton1_Click()
End Sub
Private Sub Worksheet_Calculate()
Dim keyCells As Range
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:I500")
If Worksheets("BA_Size").ToggleButton1.Value = True Then
Dim i As Integer
For i = 1 To UBound(myArr)
If keyCells(i, 1).Value <> myArr(i, 1) Then
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
Sheet1.Cells(nextrow, "A").Value = (keyCells(i, 1).Value - myArr(i, 1))
End If
Next i
End If
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
Untested:
Private Sub Worksheet_Calculate()
Dim keyCells As Range, i As Long, diff, cKey As Range
'exit if togglebutton not on
If Not Worksheets("BA_Size").ToggleButton1.Value Then Exit Sub
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:I500")
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
For i = 1 To UBound(myArr)
Set cKey = keyCells(i, 1)
If cKey.Value <> myArr(i, 1) Then
diff = (cKey.Value - myArr(i, 1))
'check value in Col K
Select Case cKey.EntireRow.Columns("K").Value
Case "John": diff = diff * cKey.EntireRow.Columns("N").Value
Case "Mary": diff = diff * cKey.EntireRow.Columns("O").Value
Case Else: diff = 0
End Select
Sheet1.Cells(nextrow, "A").Value = diff
nextrow = nextrow + 1
End If
Next i
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
The purpose is to open a workbook from SharePoint, set the auto filter, copy filtered range into the existing sheet.
The two longest pieces are opening the workbook and pasting as values.
I want to store the filtered range in the array and then assign this array to the existing worksheet (instead of copy - paste).
I have another module from which I am running all the subs (this is one of them). In that module I am starting with the below.
Public Sub TurnOffFunctionality()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
End Sub
Sub OpenWorkbookWithPopulation()
strFilePath = *Path to the SharePoint*
period = 202009
file = period & "_FR05_GRIR_Population"
strFileName = file & ".xlsb"
Set wbkopen = Workbooks.Open(strFilePath & strFileName, ReadOnly:=True, UpdateLinks:=False)
With Workbooks(file)
.Worksheets("ERP Extract").AutoFilterMode = False
.Worksheets("ERP Extract").Range("A1").AutoFilter
.Worksheets("ERP Extract").Range("A1").AutoFilter field:=17, Criteria1:="Trade"
.Worksheets("ERP Extract").Range("A1").AutoFilter field:=18, Criteria1:=">" & 90
.Worksheets("ERP Extract").AutoFilter.Range.Copy
cockpit = .Worksheets("Cockpit").Range("C6:C12").Value2
End With
With Workbooks("Master_Template_Working")
.Worksheets("Aged GRNI_Pop").Range("A1").PasteSpecial xlPasteValues
.Worksheets("Instructions").Range("C38:C44") = cockpit
End With
Workbooks(file).Close SaveChanges:=False
End Sub
You can try something like this (not tested):
With Workbooks(file)
With .Worksheets("ERP Extract")
.AutoFilterMode = False
Dim Data As Variant
' If this doesn't work, use another way.
Data = .Range("A1").CurrentRegion.Value
End With
cockpit = .Worksheets("Cockpit").Range("C6:C12").Value2
End With
Dim ColumnsCount As Long
ColumnsCount = UBound(Data, 2)
Dim i As Long ' Source Rows Counter
Dim j As Long ' Columns Counter
Dim k As Long ' Destination Rows Counter
k = 1 ' account for headers (i = 2 To ...)
For i = 2 To UBound(Data, 1)
If Data(i, 17) = "Trade" And Data(i, 18) > 90 Then
k = k + 1
For j = 1 To ColumnsCount
Data(k, j) = Data(i, j)
Next j
End If
Next i
With Workbooks("Master_Template_Working")
With .Worksheets("Aged GRNI_Pop").Range("A1")
.Resize(k, ColumnsCount).Value = Data
End With
.Worksheets("Instructions").Range("C38:C44") = cockpit
End With
I have a for next loop that runs through a couple hundred thousand lines making changes on most. Could an array to make this code run faster?
The example of my for loop. Sometimes it gets overloaded and crashes Excel. (FYI my loop has to run bottom to top for it to do its intended purpose.)
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
Set shFullYearData = .Sheets("FullYearData")
End With
Dim i As Long
Dim LastRowW As Long
On Error Resume Next
Call TurnOffCalc
FirstRowW = shWorkBook.Cells(1, 1).Row
FirstColW = shWorkBook.Cells(1, 1).Column
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
i = LastRowW
Sum = 0
shWorkBook.Activate
For i = LastRowW To 1 Step -1
If shWorkBook.Cells(i, 7) = shWorkBook.Cells(i - 1, 7) Then
shWorkBook.Cells(i, 26) = vbNullString
End If
If shWorkBook.Cells(i, 26).Value <> "" Then
shWorkBook.Cells(i, 27) = Sum + Cells(i, 25).Value
Sum = 0
ElseIf shWorkBook.Cells(i, 26).Value = "" Then
Sum = shWorkBook.Cells(i, 25).Value + Sum
End If
Next
p = FirstRowW + 1
For p = FirstRowW + 1 To LastRowW Step 1
shWorkBook.Cells(p, 28) = Application.WeekNum(shWorkBook.Cells(p, 3))
Next
shWorkBook.Cells(1, 28).Value = "Week Number"
Call TurnOnCalc
End Sub
Try something like this:
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Dim i As Long, Sum
Dim LastRowW As Long, LastColW As Long, tbl As Range, data
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
'Set shFullYearData = .Sheets("FullYearData")
End With
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
Set tbl = shWorkBook.Range("A1").Resize(LastRowW, 28) 'include "Week number" (?)
data = tbl.Value 'get the range value as an array
data(1, 28) = "Week Number"
Sum = 0
For i = LastRowW To 1 Step -1
If data(i, 7) = data(i - 1, 7) Then data(i, 26) = vbNullString
If data(i, 26).Value <> "" Then
data(i, 27) = Sum + data(i, 25).Value
Sum = 0
Else
Sum = data(i, 25).Value + Sum
End If
If i > 1 Then data(i, 28) = CLng(Format(data(i, 3), "ww"))
Next
tbl.Value = data 'return the data
End Sub
I am working on a project, which takes a checksheet that the user creates and fills out
and, when the user runs a macro, creates a new workbook that extrapolates and expands the checksheet data, as shown here
What it does is it goes through each of those number labor codes, and runs down the checksheet for all the applicable items, addending them to the list.
Now...I have this working fine, and run through the basic testing. I save the checksheet as an array and pass it through to the new workbook, filtering and creating the new workbook line-by-line.
I just can't help but think that there's a much easier way to do this, as the way I'm doing it now just doesn't seem to be the simplest and most stable way.
I'm open to sharing my code I have so far, but was wondering if you were given this senario, how you would approach it.
Here is the link to my file: https://www.dropbox.com/s/2gobdx1rcabquew/Checksheet_Template_R3.0%20-%20StkOvrflw.xls
Main module, which checks for errors and corrects formatting:
Option Explicit
Public FamilyName As String
Public ModelName As String
Public TaskArray() As Variant
Public TaskArrayRowCount As Integer
Public TaskArrayColCount As Integer
Sub CreateTemplate()
Application.EnableEvents = False
Application.ScreenUpdating = False
'Main SubModule. Runs Formatting and Template Generation
Dim thisWB As Workbook
Dim TaskArray() As Variant
Dim i As Range
Dim MajMinYesNo As Boolean
Dim OPOYesNo As Boolean
If MsgBox("Are you ready to generate the Template?", vbYesNo, "Ready?") = vbNo Then
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
MajMinYesNo = False
OPOYesNo = False
Set thisWB = ActiveWorkbook
FamilyName = thisWB.Names("Family_Name").RefersToRange
ModelName = thisWB.Names("Model_No").RefersToRange
Call CreateArray(thisWB)
'Scans Form_Type Column for "R", "S", or "A-E"
For Each i In Range("CS_FormType")
If i Like "[RS]" Then
MajMinYesNo = True
ElseIf i Like "[A-E]" Then
OPOYesNo = True
End If
Next
'Generates Templates As Needed
If MajMinYesNo Then
If MsgBox("Generate Major/Minor Template?", vbYesNo) = vbYes Then
Call MajorMinor_Generate.GenerateMajorMinor(thisWB)
End If
End If
If OPOYesNo Then
If MsgBox("Generate OPO Template?", vbYesNo) = vbYes Then
Call OPO_Generate.GenerateOPO(thisWB)
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("DONE!")
End Sub
Sub CreateArray(thisWB As Workbook)
'Checks formatting and creates array TaskArray() with all the checksheet data
With thisWB.Sheets(1)
'Confirms equal number of rows in columns "CS_TaskNo", "CS_FormType", and "CS_Task"
If (Not Range("CS_TaskNo").Rows.count = Range("CS_FormType").Rows.count) _
Or (Not Range("CS_TaskNo").Rows.count = Range("CS_Task").Rows.count) Then
MsgBox ("Task_No, Form_Type, and Task_Desc row count does not match. Please fix and try again")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
Call FormatCheck
Application.Union(Range("CS_Heading"), Range("CS_TaskNo"), Range("CS_FormType"), Range("CS_Task"), Range("CS_LaborCodes"), Range("CS_Checks")).Name = "TaskArray"
TaskArrayRowCount = Range("TaskArray").Rows.count
TaskArrayColCount = Range("TaskArray").Columns.count
ReDim TaskArray(TaskArrayRowCount, TaskArrayColCount)
TaskArray = Range("TaskArray").Value
End With
End Sub
Sub FormatCheck()
'Checks for valid labor codes and Form Types
If (Not CheckFormType()) Or (Not CheckLC()) Then
MsgBox ("Errors found, please check red-highlighted cells")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
End Sub
Function CheckFormType()
'Returns False if there's a bad Form_Type entry in range "CS_FormType", True if all OK
Dim i As Range
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_FormType")
Trim (UCase(i.Value))
If Not (i Like "[ABCDEFRS]") Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Next
CheckFormType = ReturnVal
End Function
Function CheckLC()
'Returns False if there's a bad error code, True if all OK _
Formats labor code ranges to add spaces as needed and checks _
labor codes for proper format (###X or ##X). Skips any labor _
codes starting with "28X"
Dim LaborCode As String
Dim LaborCodeLength As Integer
Dim i As Range
Dim j As Integer
Dim LCCell As Range
Dim LCArray() As String
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_LaborCodes")
Trim (UCase(i.Value))
LaborCode = i.Value
If Not Left(LaborCode, 3) Like "28?" Then
LaborCodeLength = Len(LaborCode)
'If string LaborCode is > 4, safe to assume it is a range of labor codes 123A-123F
Select Case LaborCodeLength
Case Is > 4
'Formats Labor Code Range String by adding spaces if necessary (i.e. 123A-123F to 123A - 123F)
For j = 2 To LaborCodeLength Step 1
If (IsNumeric(Mid(LaborCode, j, 1))) And Not IsNumeric(Mid(LaborCode, j + 1, 1)) And Not (Mid(LaborCode, j + 2, 1) = " ") Then
LaborCode = Left(LaborCode, j + 1) & " " & Mid(LaborCode, j + 2)
ElseIf IsNumeric(Mid(LaborCode, j, 1)) And Not (Mid(LaborCode, j - 1, 1) = " ") And Not IsNumeric(Mid(LaborCode, j - 1, 1)) Then
LaborCode = Left(LaborCode, j - 1) & " " & Mid(LaborCode, j)
End If
Next
i = LaborCode
LCArray = Split(LaborCode, " ")
'confirms the labor codes are valid
If (Not IsLaborCode(LCArray(0))) Or (Not IsLaborCode(LCArray(2))) Or (Not IsLaborCodeRange(LCArray(0), LCArray(2))) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case 0 To 4
If Not (IsLaborCode(LaborCode)) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case Else
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End Select
End If
Next
CheckLC = ReturnVal
End Function
Function IsLaborCode(LC As String) As Boolean
'returns True if Labor Code is valid, False if invalid _
Labor Code is valid if it is 2 or 3 numbers followed by a letter _
labor code format : ###X or ##X
If LC Like "###[A-Z]" Or LC Like "##[A-Z]" Then
IsLaborCode = True
Else
IsLaborCode = False
End If
End Function
Function IsLaborCodeRange(LCOne As String, LCTwo As String) As Boolean
'returns True if the LC range is valid, False if invalid. _
checks the numerical values to make sure they match and _
makes sure the letters are ascending
If (StrComp(Left(LCOne, Len(LCOne) - 1), Left(LCTwo, Len(LCTwo) - 1)) = 0) And LCOne < LCTwo Then
IsLaborCodeRange = True
Else
IsLaborCodeRange = False
End If
End Function
And here is the other module which actually takes the array and creates the new workbook:
Sub GenerateMajorMinor(thisWB As Workbook)
Dim newWB As Workbook
Dim MajMinArray() As Variant
Set newWB = Workbooks.Add
With newWB
Call FormatWorkbook
Call CreateMajMinArray(newWB, MajMinArray)
Call PopulateItemMaster(MajMinArray)
Call PopulateLaborLink(MajMinArray)
Call SaveFile(newWB, thisWB)
End With
End Sub
Sub SaveFile(newWB As Workbook, thisWB As Workbook)
'saves new workbook into the same file path as the checksheet
Dim i As Integer
Dim FileSavePath As String
Dim FamNameSave As String
FamNameSave = Replace(FamilyName, "/", "_")
i = 1
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + ".xls"
a: If Dir(FileSavePath) <> "" Then
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + "(" + CStr(i) + ").xls"
i = i + 1
GoTo a:
End If
newWB.SaveAs FileSavePath, FileFormat:=56
End Sub
Sub FormatWorkbook()
'Names and formats sheets
Sheets(1).Name = "Item_Master"
Sheets(2).Name = "Labor_Link"
With Sheets(1)
.Range("A1") = "Company_No"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Record_Status"
.Range("E1") = "Task_Desc"
.Range("F1") = "Task_No"
.Range("G1") = "Task_Seq"
.Range("H1") = "Is_Parametric"
End With
With Sheets(2)
.Range("A1") = "Company_Name"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Labor_Code"
.Range("E1") = "Print_Control"
.Range("F1") = "Record_Status"
.Range("G1") = "Task_No"
End With
End Sub
Sub CreateMajMinArray(newWB As Workbook, MajMinArray As Variant)
'creates array, removing any OPO/BTS labor codes
With Sheets(3)
Application.EnableEvents = True
Application.ScreenUpdating = True
Dim rng As Range
Set rng = .Range(.Range("A1"), .Cells(TaskArrayRowCount, TaskArrayColCount))
rng = TaskArray
For i = 1 To .Range("A1").End(xlDown).Row Step 1
If .Cells(i, 2) Like "[A-E]" Then
.Rows(i).Delete
i = i - 1
End If
Next
For i = 1 To .Range("A1").End(xlToRight).Column Step 1
If Left(.Cells(1, i), 3) Like "28E" Then
.Columns(i).Delete
i = i - 1
End If
Next
ReDim MajMinArray(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)
MajMinArray = .Range(.Range("A1"), .Cells(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)).Value
.Cells.Clear
End With
End Sub
Sub PopulateItemMaster(MajMinArray As Variant)
With Sheets(1)
'Populates "Item_Master" Sheet
For i = 2 To UBound(MajMinArray) Step 1
.Cells(i, 2) = FamilyName
.Cells(i, 3) = MajMinArray(i, 2)
.Cells(i, 4) = "1"
.Cells(i, 5) = MajMinArray(i, 3)
.Cells(i, 6) = MajMinArray(i, 1)
.Cells(i, 7) = MajMinArray(i, 1)
Next
End With
End Sub
Sub PopulateLaborLink(MajMinArray As Variant)
Dim i As Integer
Dim LaborCode As String
Dim RowCount As Long
Dim LCArray() As String
Dim LastLetter As String
Dim LastFormType As String
'Initializes RowCount and PrintControl
RowCount = 2
PrintControl = 10
With Sheets(2)
For i = 4 To UBound(MajMinArray, 2) Step 1
LaborCode = Trim(MajMinArray(1, i))
'If Labor Code String length is > 4, safe to assume that it is a range of labor codes
Select Case Len(LaborCode)
Case Is > 4
LCArray = Split(LaborCode, " ")
'checks to see if LCArray(0) and LCArray(2) has values
If LCArray(0) = "" Or LCArray(2) = "" Then
MsgBox ("Error with Labor Code range. Please check and re-run")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
LastLetter = Chr(Asc(Right$(LCArray(2), 1)) + 1)
LCArray(2) = Replace(LCArray(2), Right$(LCArray(2), 1), LastLetter)
Do
Call PrintLaborLinkLines(MajMinArray, LCArray(0), RowCount, i)
LastLetter = Chr(Asc(Right$(LCArray(0), 1)) + 1)
LCArray(0) = Replace(LCArray(0), Right$(LCArray(0), 1), LastLetter)
Loop Until LCArray(0) = LCArray(2)
Erase LCArray()
Case Is <= 4
Call PrintLaborLinkLines(MajMinArray, LaborCode, RowCount, i)
End Select
Next
End With
End Sub
Sub PrintLaborLinkLines(MajMinArray As Variant, LaborCode As String, RowCount As Long, i As Integer)
Dim PrintControl As Long
PrintControl = 10
With Sheets(2)
For x = 2 To UBound(MajMinArray) Step 1
If UCase(MajMinArray(x, i)) = "Y" Then
If LastFormType <> MajMinArray(x, 2) Then
PrintControl = 10
End If
.Cells(RowCount, 2) = FamilyName
.Cells(RowCount, 3) = MajMinArray(x, 2)
.Cells(RowCount, 4) = LaborCode
.Cells(RowCount, 5) = PrintControl
.Cells(RowCount, 6) = "1"
.Cells(RowCount, 7) = MajMinArray(x, 1)
RowCount = RowCount + 1
PrintControl = PrintControl + 10
LastFormType = MajMinArray(x, 2)
End If
Next
End With
End Sub
If restructuring the order of the data on the new sheet is possible it seems as though you could copy only visible cells and then write a simple loop to bring in any data that is not explicit (ie Labor Code).