0
VBAを初めてご利用いただきありがとうございます。ここの専門家のおかげで、私はいくつかのコードをコピーして自分のニーズに合わせて修正することができました。基本的には、さまざまな機能を実行するためのコマンドボタンです。しかし、エクセル2007で他のコンピュータにファイルを保存しようとすると（vbaが動作していることを確認した）、メッセージポップアップVBAコードはマルコ対応のファイルタイプでは実行できません
"次の機能はマクロなしのワークブック：
VBプロジェクト
、これらの機能を使用してファイルを保存していない]をクリックし、マクロ有効ファイルの種類を選択するには...」
はさえ、私はをクリックしないと、その後保存しますそれはxlsmとして。ファイルを開くと、すべてのvbaコードが無効になります。私はそれが2007年にExcelで実行できなかった次のコードの行に起因するのかどうか疑問に思っています。
コードが混乱することに対する謝罪。
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
Excel 2007でマクロオプションが有効になっているかどうかを確認してください。同じ問題に遭遇しました。マクロオプションとサポートされているアドオンが無効になっていました。 – Siva