マクロの説明
１．Sub Sample7()はsheet４の列をソートするマクロです。
(単独では、このマクロでソートできる)
２．Sub sample2()はsheet４のソート以外は完成しています。
やりたいこと
Sub sample2()の中にsheet４の重複データを削除したもののソートのコードを組み込みたい。
但し、組み込むとしてSub Sample7()のコードでよいのか、初心者なのでよくわかりません。
なお、Sub sample2()のマクロは途中省いています。
Sub Sample7()
Sheets("sheet4").Range("A1:A1135").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes
End Sub
Sub sample2()
Dim data As Variant 'データコピー用の使いまわし配列
Dim dic As Object
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
'Sheet4～5のA列をリセット
Sheets("Sheet4").Range("A2:A" & Rows.Count).ClearContents
Sheets("Sheet5").Range("C3:C" & Rows.Count).ClearContents
↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'Sheet4に重複していないデータを書き込み
With Sheets("Sheet4")
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(dic.Count).Value = Application.Transpose(dic.keys)
'Sheet4のC列をSheet5にコピー
data = .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
Sheets("Sheet5").Range("C3").Resize(UBound(data)).Value = data
Set dic = Nothing
End Sub
Sheetに描画オブジェクト Shapes(1) があります。
これを回転させるのに、次のコードだとエラーになります。
Sub Test()
ActiveSheet.Shapes(1).ShapeRange.Rotation = 90
End Sub
次のコードだと実行できます。
Sub Test2()
ActiveSheet.Shapes(1).Select
Selection.ShapeRange.Rotation = 90
End Sub
Selectしないで回転させるにはどう書いたらいいのでしょうか？教えてください。
VBSで現在下記のようなコードを組んでいます。
動作としてはコードが組んであるVBSファイルにエクセルシートをドラック＆ドロップすると、ブックのパスが外れてファイル名の先頭に
シート内のセルE5の文字がつくようになっています。
そしてそのファイル名に指定した文字がある場合
指定したフォルダへ移動されます。
今回行いたいのは、その移動したあとの処理で
移動したファイルをそのフォルダ内でコピーして
名前を変更したいです。
例えば移動してきたファイル名が
#101-1test.xlsxだとして、そのファイルをコピーして
ABC101-1_DEFG.xlsxという名前で同じフォルダ内にコピーしたい。
ファイルの中身は同じだけど、名前を変更して同じフォルダ内に
ファイルを作成したいということです。
ちなみに移動してきた時の始めのファイル名、#〇〇〇-〇は必ずこの形です。
なので、頭のシャープと-1以降の文字を削除して
〇〇〇の手前につける文字と、-〇以降につける文字が指定できれば完璧です。
このようなことができるかわかりませんが、よろしくお願いします。
よろしくお願いします。
Option Explicit
'Excel 2013 Later Japenese Version Available
'REF:
'REF:
'''///---定数の設定Set Enumuragion---///'''
Const PWD="aaaaa"
Const msoLanguageIDInstall = 1
'''///---変数の宣言---///'''
Dim objArgs, I , strFile
Dim objFile, objFolder,objPath,strScr
Dim xlApp,Wb
Dim objWShell : Set objWShell = Createobject("WScript.Shell")
Dim FSO : Set FSO = Createobject("Scripting.FileSystemObject")
'''///---ファイル処理開始 Start Document File Conversion---///'''
Set objArgs = Wscript.Arguments
For I = 0 to objArgs.Count-1
set objFile = FSO.GetFile(cstr(objArgs(I)))
If Lcase(Left(FSO.GetExtensionName(objFile.Path) ,4) )="xlsx" Then
Set xlApp =CreateObject("Excel.Application")
If xlApp.Version < 14 Then xlApp.Quit: Set xlApp = Nothing:wscript.Quit
xlApp.DisplayAlerts=False
xlApp.Visible = False
set wb=xlapp.WorkBooks.Open(objFile.Path,0,false,,PWd,,True,,false,false,,true,true)
if wb.HasPassword=true then
wb.Saveas objFile.Path,,"","",False
else
wb.Saveas objFile.Path,,Pwd,"",False
End if
Dim n
n = wb.Worksheets(1).Range("E5").Value & "_" & wb.Name
wb.close
FSO.GetFile(objFile.Path).Name = n
If Mid(objFile.name, 5, 2) = "-1" Then
FSO.MoveFile objFile.path, "F:\A\"
Else
MsgBox objFile.Name & " 該当せず"
End If
set wb=nothing
End If
Next
xlApp.DisplayAlerts=True
xlApp.Quit
set xlApp = Nothing
VBSで現在下記のようなコードを組んでいます。
動作としてはコードが組んであるVBSファイルにエクセルシートをドラック＆ドロップすると、ブックのパスが外れてファイル名の先頭に
シート内のセルE5の文字がつくようになっています。
そしてそのファイル名に指定した文字がある場合
指定したフォルダへ移動されます。
今回行いたいのは、その移動したあとの処理で
移動したファイルをそのフォルダ内でコピーして
名前を変更したいです。
例えば移動してきたファイル名が
#101-1test.xlsxだとして、そのファイルをコピーして
ABC101-1_DEFG.xlsxという名前で同じフォルダ内にコピーしたい。
ファイルの中身は同じだけど、名前を変更して同じフォルダ内に
ファイルを作成したいということです。
ちなみに移動してきた時の始めのファイル名、#〇〇〇-〇は必ずこの形です。
なので、頭のシャープと-1以降の文字を削除して
〇〇〇の手前につける文字と、-〇以降につける文字が指定できれば完璧です。
このようなことができるかわかりませんが、よろしくお願いします。
よろしくお願いします。
Option Explicit
'Excel 2013 Later Japenese Version Available
'REF:
'REF:
'''///---定数の設定Set Enumuragion---///'''
Const PWD="aaaaa"
Const msoLanguageIDInstall = 1
'''///---変数の宣言---///'''
Dim objArgs, I , strFile
Dim objFile, objFolder,objPath,strScr
Dim xlApp,Wb
Dim objWShell : Set objWShell = Createobject("WScript.Shell")
Dim FSO : Set FSO = Createobject("Scripting.FileSystemObject")
'''///---ファイル処理開始 Start Document File Conversion---///'''
Set objArgs = Wscript.Arguments
For I = 0 to objArgs.Count-1
set objFile = FSO.GetFile(cstr(objArgs(I)))
If Lcase(Left(FSO.GetExtensionName(objFile.Path) ,4) )="xlsx" Then
Set xlApp =CreateObject("Excel.Application")
If xlApp.Version < 14 Then xlApp.Quit: Set xlApp = Nothing:wscript.Quit
xlApp.DisplayAlerts=False
xlApp.Visible = False
set wb=xlapp.WorkBooks.Open(objFile.Path,0,false,,PWd,,True,,false,false,,true,true)
if wb.HasPassword=true then
wb.Saveas objFile.Path,,"","",False
else
wb.Saveas objFile.Path,,Pwd,"",False
End if
Dim n
n = wb.Worksheets(1).Range("E5").Value & "_" & wb.Name
wb.close
FSO.GetFile(objFile.Path).Name = n
If Mid(objFile.name, 5, 2) = "-1" Then
FSO.MoveFile objFile.path, "F:\A\"
Else
MsgBox objFile.Name & " 該当せず"
End If
set wb=nothing
End If
Next
xlApp.DisplayAlerts=True
xlApp.Quit
set xlApp = Nothing
VBSで現在下記のようなコードを組んでいます。
動作としてはコードが組んであるVBSファイルにエクセルシートをドラック＆ドロップすると、ブックのパスが外れてファイル名の先頭に
シート内のセルE5の文字がつくようになっています。
やりたいのはその後の処理で
たとえば、ブックの名前が先頭から＃101-1ならAのフォルダへ移動
＃101-2ならBのフォルダへ移動という感じのことがしたいです。
つまりファイル名に-1や-2といった文字が先頭から数えて5番のところにあれば
その条件に合わせてファイルを指定のフォルダへ移動させたいということです。
正式には-が先頭から5文字目で数字が先頭から6番になります。
どのようにすればよいか教えてください。
Option Explicit
'Excel 2013 Later Japenese Version Available
'REF:
'REF:
'''///---定数の設定Set Enumuragion---///'''
Const PWD="aaaaa"
Const msoLanguageIDInstall = 1
'''///---変数の宣言---///'''
Dim objArgs, I , strFile
Dim objFile, objFolder,objPath,strScr
Dim xlApp,Wb
Dim objWShell : Set objWShell = Createobject("WScript.Shell")
Dim FSO : Set FSO = Createobject("Scripting.FileSystemObject")
'''///---ファイル処理開始 Start Document File Conversion---///'''
Set objArgs = Wscript.Arguments
For I = 0 to objArgs.Count-1
set objFile = FSO.GetFile(cstr(objArgs(I)))
If Lcase(Left(FSO.GetExtensionName(objFile.Path) ,4) )="xlsx" Then
Set xlApp =CreateObject("Excel.Application")
If xlApp.Version < 14 Then xlApp.Quit: Set xlApp = Nothing:wscript.Quit
xlApp.DisplayAlerts=False
xlApp.Visible = False
set wb=xlapp.WorkBooks.Open(objFile.Path,0,false,,PWd,,True,,false,false,,true,true)
if wb.HasPassword=true then
wb.Saveas objFile.Path,,"","",False
else
wb.Saveas objFile.Path,,Pwd,"",False
End if
Dim n
n = wb.Worksheets(1).Range("E5").Value & "_" & wb.Name
wb.close
FSO.GetFile(objFile.Path).Name = n
set wb=nothing
End If
Next
xlApp.DisplayAlerts=True
xlApp.Quit
set xlApp = Nothing
