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 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
<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">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</code>
"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 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
<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">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</code>
