Sorry that I am new to VBA, thanks to all the experts here I am able to copy some of the codes and modify them to suit my needs. Basically, they are just a couple of command buttons which carry out various functions. It work out fine in my excel 2010. However, when I try to save the file in my another computer with Excel 2007 (Confirmed that vba is running), a message popup saying
"The following Features cannot be saved in a macro-free workbooks:
VB Project
To save a file with these features, click no, and then choose a macro-enabled file type..."
Even I clicked no and then save it as xlsm. When I opened the file, all the vba codes are disabled. I just wonder whether it is due to any line of the following codes that could not be run in excel 2007. Many thanks for your help!
Apologies for the codes being a mess.
Private Sub CommandButton1_Click()
' Defines variables
Dim Wb1 As Workbook, Wb2 As Workbook
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Sets Wb1 as the current (destination) workbook
Set Wb1 = ThisWorkbook
' Sets Wb2 as the defined workbook and opens it - Update filepath / filename as required
Set Wb2 = Workbooks.Open("\\new_admin\MASTER_FILE.xlsx")
' Sets LastRow as the first blank row of Wb1 Sheet1 based on column A (requires at least header if document is otherwise blank)
lastrow = Sheets(1).Cells(Rows.count, "A").End(xlUp).Row + 1
' With workbook 2
With Wb2
' Activate it
.Activate
' Activate the desired sheet - Currently set to sheet 1, change the number accordingly
.Sheets(1).Activate
' Copy the used range of the active sheet
.ActiveSheet.UsedRange.Copy
End With
' Then with workbook 1
With Wb1.Sheets(1)
' Activate it
.Activate
' Select the first blank row based on column A
.Range("A1").Select
' Paste the copied data
.Paste
End With
' Close workbook 2
Wb2.Close
' Re-enables screen updating
Application.ScreenUpdating = False
End Sub
Private Sub CommandButton2_Click()
' Defines variables
Dim Wb1 As Workbook, Wb2 As Workbook
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Sets Wb1 as the current (destination) workbook
Set Wb1 = ThisWorkbook
' Sets Wb2 as the defined workbook and opens it - Update filepath / filename as required
Set Wb2 = Workbooks.Open("C:\Users\admin\Desktop\Accom_Master_File.xlsx")
' Sets LastRow as the first blank row of Wb1 Sheet1 based on column A (requires at least header if document is otherwise blank)
lastrow = Sheets(2).Cells(Rows.count, "A").End(xlUp).Row + 1
' With workbook 2
With Wb2
' Activate it
.Activate
' Activate the desired sheet - Currently set to sheet 1, change the number accordingly
.Sheets(1).Activate
' Copy the used range of the active sheet
.ActiveSheet.UsedRange.Copy
End With
' Then with workbook 1
With Wb1.Sheets(2)
' Activate it
.Activate
' Select the first blank row based on column A
.Range("A1").Select
' Paste the copied data
.Paste
End With
' Close workbook 2
Wb2.Close
' Re-enables screen updating
Application.ScreenUpdating = False
Dim wkb As Workbook
Set wkb = ThisWorkbook
wkb.Sheets("Sheet1").Activate
End Sub
Private Sub CommandButton3_Click()
Range("B2").CurrentRegion.Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ThisWorkbook.Sheets("Sheet2").Range("B:C").Delete xlUp
ThisWorkbook.Sheets("Sheet2").Columns(2).Copy
ThisWorkbook.Sheets("Sheet2").Columns(1).Insert
ThisWorkbook.Sheets("Sheet2").Columns(3).Delete
End Sub
Private Sub CommandButton4_Click()
Dim dicKey As String
Dim dicValues As String
Dim dic
Dim data
Dim x(1 To 35000, 1 To 24)
Dim j As Long
Dim count As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
data = Range("A2:X" & lastrow) ' load data into variable
With CreateObject("scripting.dictionary")
For i = 1 To UBound(data)
If .Exists(data(i, 2)) = True Then 'test to see if the key exists
x(count, 3) = x(count, 3) & ";" & data(i, 3)
x(count, 8) = x(count, 8) & ";" & data(i, 8)
x(count, 9) = x(count, 9) & ";" & data(i, 9)
x(count, 10) = x(count, 10) & ";" & data(i, 10)
x(count, 21) = x(count, 21) & ";" & data(i, 21)
Else
count = count + 1
dicKey = data(i, 2) 'set the key
dicValues = data(i, 2) 'set the value for data to be stored
.Add dicKey, dicValues
For j = 1 To 24
x(count, j) = data(i, j)
Next j
End If
Next i
End With
Rows("2:300").EntireRow.Delete
Sheets("Sheet1").Cells(2, 1).Resize(count - 1, 24).Value = x
End Sub
Private Sub CommandButton5_Click()
If ActiveSheet.AutoFilterMode Then Selection.AutoFilter
ActiveCell.CurrentRegion.Select
With Selection
.AutoFilter
.AutoFilter Field:=1, Criteria1:="ACTIVE"
.AutoFilter Field:=5, Criteria1:="NUMBERS"
.Offset(1, 0).Select
End With
Dim ws As Worksheet
Dim rVis As Range
Application.ScreenUpdating = False
For Each ws In Worksheets
Do Until ws.Columns("A").SpecialCells(xlVisible).count = ws.Rows.count
Set rVis = ws.Columns("A").SpecialCells(xlVisible)
If rVis.Row = 1 Then
ws.Rows(rVis.Areas(1).Rows.count + 1 & ":" & rVis.Areas(2).Row - 1).Delete
Else
ws.Rows("1:" & rVis.Row - 1).Delete
End If
Loop
Next ws
Application.ScreenUpdating = True
Dim LR As Long
LR = Cells(Rows.count, 1).End(xlUp).Row
Rows(LR).Copy
Rows(LR + 2).Insert
End Sub
Private Sub CommandButton6_Click()
Columns("A").Delete
Dim lastrow As Long
lastrow = Range("A2").End(xlDown).Row
Range("X2:X" & lastrow).FormulaR1C1 = "=IF(RC[+1]=""PAYING"", VLOOKUP(RC[-23],'Sheet2'!R1C1:R20000C8,8,0),""PENDING"")"
Range("Y2:Y" & lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-24],'Sheet2'!R1C1:R20000C8,2,0), ""PENDING"")"
Range("Z2:Z" & lastrow).FormulaR1C1 = "=(LEN(RC[-24])-LEN(SUBSTITUTE(RC[-24], "";"", """"))+1)*1200"
Range("AA2:AA" & lastrow).FormulaR1C1 = "=VLOOKUP(RC[-26],'Sheet3'!R2C2:R220C4,2,0)"
Range("AB2:AB" & lastrow).FormulaR1C1 = "=VLOOKUP(RC[-27],'Sheet3'!R2C2:R220C4,3,0)"
Range("AC2:AC" & lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-28],'Sheet4'!R1C1:R30C3,2,0),"""")"
Range("AD2:AD" & lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-29],'Sheet4'!R1C4:R30C6,2,0),"""")"
Columns("X:AD").EntireColumn.AutoFit
Sheets(1).Columns(24).NumberFormat = "@"
Sheets(1).Columns(25).NumberFormat = "@"
Sheets(1).Columns(29).NumberFormat = "@"
Sheets(1).Columns(30).NumberFormat = "@"
End Sub
Private Sub CommandButton7_Click()
Sheet1.Cells.Clear
End Sub
