Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, Optional ByVal dx As Long = 0, Optional ByVal dy As Long = 0, Optional ByVal dwData As Long = 0, Optional ByVal dwExtractInfo As Long = 0)
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As coordinate) As Long
Type coordinate
x As Long
y As Long
End Type
Option Explicit
Public Sub auto_open()
'キー無効化
Application.OnKey "{F5}", ""
Application.OnKey "{F3}", ""
End Sub
Sub ひとつおきコピー()
'
' テスト Macro
'
'
Dim i As Integer
For i = 1 To 1996
ActiveCell.FormulaR1C1 = "=R[-1]C"
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(2, 0).Activate
Next i
End Sub
Sub 空白全削除()
Dim STR As String, i As Integer
Sheets("伝票抽出").Select
For i = 1 To 50
STR = Cells(i, 1).Value
STR = REPLACE(STR, ChrW(12288), "") '全角スペースを削除
STR = REPLACE(STR, ChrW(9), "") 'タブ区切りを削除
STR = REPLACE(STR, ChrW(32), "") '半角スペースを削除
Cells(i, 1).Value = STR
Next i
End Sub
Sub メール作成()
Dim cbdata As New DataObject, text2 As String
Dim den_num2 As String
Dim combine_name As String
Dim arr2(36) As Variant
Dim i As Integer, p As Integer
Sheets("返金メール送信履歴").Select
If Range("B7").Value = "注文番号コピー失敗" Then
MsgBox "注文番号コピー失敗"
Else
den_num2 = Range("C1").Value
combine_name = Range("C4").Value
arr2(0) = combine_name & vbCrLf
arr2(1) = "平素は格別なお引き立てを賜り"
arr2(2) = "誠にありがとうございます。" & vbCrLf
arr2(3) = "ご注文番号：" & den_num2 & "の"
arr2(4) = "キャンセル分につきまして、"
arr2(5) = "ご返金を、銀行振込にて"
arr2(6) = "行わせていただければと存じますので、"
arr2(7) = "大変お手数ではございますが、"
arr2(8) = "下記フォームに返金先口座情報のご入力と"
arr2(9) = "ご返信をお願いいたします。" & vbCrLf
arr2(10) = "※受付からご返金まで"
arr2(11) = "2～3銀行営業日程度お日にちをいただきます。" & vbCrLf
arr2(12) = "◎返信先メールアドレス"
arr2(13) = "info@yodobashi.com" & vbCrLf
arr2(14) = "----------------------------------------"
arr2(15) = "・お名前：" & combine_name
arr2(16) = "----------------------------------------"
arr2(17) = "・注文番号：" & den_num2
arr2(18) = "----------------------------------------"
arr2(19) = "・銀行名："
arr2(20) = "----------------------------------------"
arr2(21) = "・支店名："
arr2(22) = "----------------------------------------"
arr2(23) = "・口座種別(普通または当座)："
arr2(24) = "----------------------------------------"
arr2(25) = "・口座番号(最大7桁)："
arr2(26) = "----------------------------------------"
arr2(27) = "・口座名義(カタカナにてご記入ください)" & vbCrLf
arr2(28) = "----------------------------------------" & vbCrLf
arr2(29) = "今後とも、ヨドバシ・ドット・コムを"
arr2(30) = "よろしくお願いいたします。" & vbCrLf
arr2(31) = Format(Date, "yyyy年mm月dd日")
arr2(32) = "株式会社ヨドバシカメラ"
arr2(33) = "お客様サ－ビスセンタ－"
arr2(34) = "担当：小宮"
arr2(35) = "info@yodobashi.com"
p = 0
text2 = arr2(p) & vbCrLf
For i = 1 To 33 '今だけ33まで
p = p + 1
text2 = text2 & arr2(p) & vbCrLf
Next i
text2 = text2 & arr2(35) & vbCrLf '今だけ
cbdata.SetText text2
cbdata.PutInClipboard
End If
End Sub
Sub 伝票番号貼り付け()
Sheets("返金メール送信履歴").Select
Dim text1 As String, cbdata As New DataObject, text2 As String
Dim den_num1 As String, familyname As String, lastname As String, den_num2 As String
Dim ID As String, combine_name As String
Dim arr1 As Variant
Dim i As Integer, p As Integer
Dim data_num As Integer
data_num = Range("C8").Value
cbdata.GetFromClipboard
text1 = cbdata.GetText
If InStr(text1, "変更") = 0 Then
text1 = REPLACE(text1, ChrW(12288), "") '全角スペースを削除
text1 = REPLACE(text1, ChrW(9), "") 'タブ区切りを削除
text1 = REPLACE(text1, ChrW(32), "") '半角スペースを削除
text1 = REPLACE(text1, vbCrLf, "") '改行を削除
text1 = REPLACE(text1, "受注番号", "")
text1 = REPLACE(text1, "販売伝票タイプZIO2ＥＣ受注処理モード参照注文番号", "■")
text1 = REPLACE(text1, "受注受付日", "■")
text1 = REPLACE(text1, "EC会員/GPCICNo.", "■")
text1 = REPLACE(text1, "お客様コード", "■")
text1 = REPLACE(text1, "名称(姓)／法人名", "■")
text1 = REPLACE(text1, "名称(名)／部署名", "■")
text1 = REPLACE(text1, "様〃", "■")
arr1 = Split(text1, "■")
den_num1 = arr1(0)
den_num2 = arr1(1)
ID = arr1(3)
familyname = arr1(5)
lastname = arr1(6)
combine_name = familyname & Space(1) & lastname & Space(1)
If Len(den_num2) = 10 Then
Cells(data_num + 2, 6).Value = den_num1
Cells(data_num + 2, 7).Value = den_num2
Cells(data_num + 2, 10).Value = ID
Cells(data_num + 2, 11).Value = combine_name
Range("C1").Value = den_num2
Range("C2").Value = familyname
Range("C3").Value = lastname
Range("C4").Value = combine_name & "様"
Range("C5").Value = den_num1
Range("C6").Value = ID
Else
MsgBox "注文番号コピー失敗"
End If
Else
MsgBox "伝票は参照で開きましょう"
End If
End Sub
Sub 口座確認メールコピーなし()
Application.ScreenUpdating = False
Range("A1:A45").Select
Selection.Copy
If Range("E7").Value = "注文番号コピー失敗" Then
Application.CutCopyMode = False
MsgBox "注文番号コピー失敗だから！"
End If
Application.ScreenUpdating = True
End Sub
Sub 返金口座サンクス()
Sheets("返金メール送信履歴").Select
Application.ScreenUpdating = False
On Error Resume Next
Dim STR As String, i As Integer, order_num As String, den_num As String
Range("C2").Select
ActiveSheet.PasteSpecial Format:="Unicode テキスト", Link:=False, _
DisplayAsIcon:=False, NoHTMLFormatting:=True
For i = 1 To 22
STR = Cells(i + 1, 3).Value
STR = REPLACE(STR, ChrW(12288), "") '全角スペースを削除
STR = REPLACE(STR, ChrW(9), "") 'タブ区切りを削除
STR = REPLACE(STR, ChrW(32), "") '半角スペースを削除
Cells(i + 1, 3).Value = STR
Next i
order_num = Right(Range("C2").Value, 10)
den_num = Mid(Range("C2").Value, 5, 10)
Range("F1").Value = order_num
Range("F5").Value = den_num
Range("A60:A89").Select
Selection.Copy
'ActiveWindow.SmallScroll ToRight:=3
'ActiveWindow.SmallScroll UP:=40
On Error GoTo 0
If Range("E7").Value = "注文番号コピー失敗" Then
Application.CutCopyMode = False
MsgBox "注文番号コピーできてないから！"
End If
Application.ScreenUpdating = True
End Sub
Sub 全角半角変換()
Dim text1 As String, cbdata As New DataObject
cbdata.GetFromClipboard
text1 = cbdata.GetText
Range("A18").Value = text1
text1 = REPLACE(text1, ChrW(12288), "") '全角スペースを削除
text1 = REPLACE(text1, ChrW(9), "") 'タブ区切りを削除
text1 = REPLACE(text1, ChrW(32), "") '半角スペースを削除
text1 = REPLACE(text1, vbCrLf, "") '改行を削除
'ざっくりコピーしたときの余分の削除
text1 = REPLACE(text1, "・", "")
text1 = REPLACE(text1, "・", "")
text1 = REPLACE(text1, "#", "")
text1 = REPLACE(text1, "口座名義", "")
text1 = REPLACE(text1, "名義", "")
text1 = REPLACE(text1, "(カタカナ)", "")
text1 = REPLACE(text1, "（カタカナ）", "")
text1 = REPLACE(text1, "(カナ)", "")
text1 = REPLACE(text1, "（カナ）", "")
text1 = REPLACE(text1, ":", "")
text1 = REPLACE(text1, "：", "")
text1 = REPLACE(text1, ">", "")
text1 = REPLACE(text1, "＞", "")
text1 = StrConv(text1, vbNarrow) '半角に変換
'法人略称変換。一旦「■」に変換。
Dim instrNum As Byte, textNum As Byte, ● As String
text1 = REPLACE(text1, "(株式会社)", "ｶﾌﾞｼｷｶﾞｲｼｬ")
text1 = REPLACE(text1, "株式会社", "ｶﾌﾞｼｷｶﾞｲｼｬ")
text1 = REPLACE(text1, "(株)", "ｶﾌﾞｼｷｶﾞｲｼｬ")
text1 = REPLACE(text1, "合同会社", "ｺﾞｳﾄﾞｳｶﾞｲｼｬ")
text1 = REPLACE(text1, "有限会社", "ﾕｳｹﾞﾝｶﾞｲｼｬ")
text1 = REPLACE(text1, "ｶﾌﾞｼｷｶﾞｲｼｬ", "■")
text1 = REPLACE(text1, "ｶﾌﾞｼｷｶｲｼｬ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｶ)"
Case textNum
● = "(ｶ"
Case 2 To textNum - 1
● = "(ｶ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ﾕｳｹﾞﾝｶﾞｲｼｬ", "■")
text1 = REPLACE(text1, "ﾕｳｹﾞﾝｶｲｼｬ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ﾕ)"
Case textNum
● = "(ﾕ"
Case 2 To textNum - 1
● = "(ﾕ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｺﾞｳﾄﾞｳｶﾞｲｼｬ", "■")
text1 = REPLACE(text1, "ｺﾞｳﾄﾞｳｶｲｼｬ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ﾄﾞ)"
Case textNum
● = "(ﾄﾞ"
Case 2 To textNum - 1
● = "(ﾄﾞ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｺﾞｳﾒｲｶﾞｲｼｬ", "■")
text1 = REPLACE(text1, "ｺﾞｳﾒｲｶｲｼｬ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ﾒ)"
Case textNum
● = "(ﾒ"
Case 2 To textNum - 1
● = "(ﾒ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｺﾞｳｼｶﾞｲｼｬ", "■")
text1 = REPLACE(text1, "ｺﾞｳｼｶｲｼｬ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｼ)"
Case textNum
● = "(ｼ"
Case 2 To textNum - 1
● = "(ｼ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｲﾘｮｳﾎｳｼﾞﾝｼｬﾀﾞﾝ", "■")
text1 = REPLACE(text1, "ｲﾘｮｳﾎｳｼﾞﾝｻﾞｲﾀﾞﾝ", "■")
text1 = REPLACE(text1, "ｼｬｶｲｲﾘｮｳﾎｳｼﾞﾝ", "■")
text1 = REPLACE(text1, "ｲﾘｮｳﾎｳｼﾞﾝ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｲ)"
Case textNum
● = "(ｲ"
Case 2 To textNum - 1
● = "(ｲ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｲｯﾊﾟﾝｻﾞｲﾀﾞﾝﾎｳｼﾞﾝ", "■")
text1 = REPLACE(text1, "ｺｳｴｷｻﾞｲﾀﾞﾝﾎｳｼﾞﾝ", "■")
text1 = REPLACE(text1, "ｻﾞｲﾀﾞﾝﾎｳｼﾞﾝ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｻﾞｲ)"
Case textNum
● = "(ｻﾞｲ"
Case 2 To textNum - 1
● = "(ｻﾞｲ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｲｯﾊﾟﾝｼｬﾀﾞﾝﾎｳｼﾞﾝ", "■")
text1 = REPLACE(text1, "ｺｳｴｷｼｬﾀﾞﾝﾎｳｼﾞﾝ", "■")
text1 = REPLACE(text1, "ｼｬﾀﾞﾝﾎｳｼﾞﾝ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｼﾔ)"
Case textNum
● = "(ｼﾔ"
Case 2 To textNum - 1
● = "(ｼﾔ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｼｬｶｲﾌｸｼﾎｳｼﾞﾝ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ﾌｸ)"
Case textNum
● = "(ﾌｸ"
Case 2 To textNum - 1
● = "(ﾌｸ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｼｭｳｷｮｳﾎｳｼﾞﾝ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｼﾕｳ)"
Case textNum
● = "(ｼﾕｳ"
Case 2 To textNum - 1
● = "(ｼﾕｳ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
text1 = REPLACE(text1, "ｶﾞｯｺｳﾎｳｼﾞﾝ", "■")
textNum = Len(text1)
instrNum = InStr(text1, "■")
Select Case instrNum
Case 1
● = "ｶﾞｸ)"
Case textNum
● = "(ｶﾞｸ"
Case 2 To textNum - 1
● = "(ｶﾞｸ)"
End Select
text1 = REPLACE(text1, "■", ●) 'もう一度置き換え
Range("B18").Value = text1
With Range("A18:B18")
.WrapText = False
.ShrinkToFit = True
End With
With cbdata
.SetText text1
.PutInClipboard
End With
End Sub
Sub 自動メール伝票番号貼り付けてメール作成()
Dim STR As String, i As Byte, row As Integer, data_num As Integer, order_num As String, den_num As String, length_A As Integer
Application.ScreenUpdating = False
On Error Resume Next
Sheets("自動メール作成").Select
data_num = Range("B14").Value
Range("D2:D26").Select
Selection.ClearContents
Range("D2").Select
ActiveSheet.PasteSpecial Format:="Unicode テキスト", Link:=False, _
DisplayAsIcon:=False, NoHTMLFormatting:=True
For i = 1 To 22
STR = Cells(i + 1, 4).Value
STR = REPLACE(STR, ChrW(12288), "") '全角スペースを削除
STR = REPLACE(STR, ChrW(9), "") 'タブ区切りを削除
STR = REPLACE(STR, ChrW(32), "") '半角スペースを削除
Cells(i + 1, 4).Value = STR
Next i
order_num = Right(Range("D2").Value, 10)
den_num = Mid(Range("D2").Value, 5, 10)
Range("B7").Value = order_num
Range("B8").Value = den_num
If Range("A13").Value = "注文番号OK" Then
Worksheets("自動メール送信済").Cells(data_num + 2, 4).Value = Range("A2").Value
Worksheets("自動メール送信済").Cells(data_num + 2, 5).Value = Range("B7").Value
Worksheets("自動メール送信済").Cells(data_num + 2, 6).Value = Range("B8").Value
length_A = Len(Range("D7").Value) - 28 'メールアドレス以外の文字数
Worksheets("自動メール送信済").Cells(data_num + 2, 7).Value = Mid(Range("D7"), 14, length_A)
'メール選択
Select Case Range("A2").Value
'返金完了メール
Case Range("D30").Value
Range("K2:K31").Select
Selection.Copy
'返金先口座再確認
Case Range("D31").Value
Range("F2:F38").Select
Selection.Copy
'返金先口座再確認（再送）
Case Range("D32").Value
MsgBox "メールの送信日付★の入力忘れずに！"
Range("G2:G53").Select
Selection.Copy
'返金完了メール（再確認）
Case Range("D33").Value
Range("H2:H33").Select
Selection.Copy
'ポイントで返金できません
Case Range("D34").Value
Range("I2:I44").Select
Selection.Copy
'ポイント返金不可（書留有Ver)
Case Range("D35").Value
Range("J2:J57").Select
Selection.Copy
'返金先口座再確認（ゆうちょ有りバージョン）
Case Range("D36").Value
Range("L2:L51").Select
Selection.Copy
'口座情報一部不明
Case Range("D37").Value
Range("M2:M41").Select
Selection.Copy
'返金完了メール（現金書留バージョン）
Case Range("D38").Value
MsgBox "発送予定日の入力忘れずに！"
Range("N2:N25").Select
Selection.Copy
'ここは別のを入れる
Case Range("D39").Value
Range("O2:O51").Select
Selection.Copy
'ゆうちょ銀行。支店名不明。
Case Range("D40").Value
Range("P2:P54").Select
Selection.Copy
'返金完了メール。塩対応Ver
Case Range("D41").Value
Range("Q2: Q20 ").Select
Selection.Copy
'キャンセル後入金
Case Range("D42").Value
Range("R2: R51 ").Select
Selection.Copy
End Select
Else
Application.CutCopyMode = False
MsgBox "注文番号が不正だから！"
End If
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Sub 自動メール作成貼り付け無()
Dim STR As String, i As Byte, row As Integer, data_num As Integer, order_num As String, den_num As String, length_A As Integer
Application.ScreenUpdating = False
Sheets("自動メール作成").Select
'メール選択
Select Case Range("A2").Value
'返金完了メール
Case Range("D30").Value
Range("K2:K31").Select
Selection.Copy
'返金先口座再確認
Case Range("D31").Value
Range("F2:F38").Select
Selection.Copy
'返金先口座再確認（再送）
Case Range("D32").Value
MsgBox "メールの送信日付★の入力忘れずに！"
Range("G2:G53").Select
Selection.Copy
'返金完了メール（再確認）
Case Range("D33").Value
Range("H2:H33").Select
Selection.Copy
'ポイントで返金できません
Case Range("D34").Value
Range("I2:I44").Select
Selection.Copy
'ポイント返金不可（書留有Ver)
Case Range("D35").Value
Range("J2:J57").Select
Selection.Copy
'返金先口座再確認（ゆうちょ有りバージョン）
Case Range("D36").Value
Range("L2:L51").Select
Selection.Copy
'口座情報一部不明
Case Range("D37").Value
Range("M2:M41").Select
Selection.Copy
'返金完了メール（現金書留バージョン）
Case Range("D38").Value
MsgBox "発送予定日の入力忘れずに！"
Range("N2:N22").Select
Selection.Copy
'キャンセル後入金
Case Range("D39").Value
Range("O2:O51").Select
Selection.Copy
'ゆうちょ銀行。支店名不明。
Case Range("D40").Value
Range("P2:P54").Select
Selection.Copy
End Select
Application.ScreenUpdating = True
End Sub
Sub 改行消失修正()
Dim s As String
Dim cbdata As New DataObject
Sheets("自動メール作成").Select
cbdata.GetFromClipboard
s = cbdata.GetText
With cbdata
.SetText ""
.PutInClipboard
End With
'横棒(-)を消す
s = REPLACE(s, vbLf, "")
s = REPLACE(s, "-", "")
s = REPLACE(s, ">", "")
s = REPLACE(s, ChrW(12288), "") '全角スペースを削除
s = REPLACE(s, ChrW(9), "") 'タブ区切りを削除
s = REPLACE(s, ChrW(32), "") '半角スペースを削除
s = REPLACE(s, "#", "")
'(・)を改行に置き換える
s = REPLACE(s, "・", vbCrLf)
'ファイルに書き込み
'OpenAsTextStream(A,B)
'A
'1 読み込み用で開きます
'2 上書き書き込み用で開きます
'8 追加書き込み用で開きます
'B
'0 ASCIIファイルとして開きます
'-1 Unicodeファイルとして開きます
'-2 システムの既定値で開きます
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFile("C:\Users\33607\Documents\一時ファイル\改行.txt").OpenAsTextStream(2, -2)
.write s
.Close
End With
Set FSO = Nothing
'Open "\\Yctfsr21\☆ec\2020年8月配属メンバー\小宮\一時ファイル\改行.txt" For Output As #1
'Print #1, S
'Close #1
'練習。ファイルから読み込んでからクリップボードへコピー
'readline 1行読み込み
'Dim buf As String
' Set FSO = CreateObject("Scripting.FileSystemObject")
' With FSO.GetFile("\\Yctfsr21\☆ec\2020年8月配属メンバー\小宮\一時ファイル\改行.txt").OpenAsTextStream
' buf = .readall
' .Close
'
'
' End With
' Set FSO = Nothing
With cbdata
.SetText s
.PutInClipboard
End With
'ファイルを開く
Dim ws As Object
Set ws = CreateObject("Wscript.Shell")
ws.Run "C:\Users\33607\Documents\一時ファイル\改行.txt"
End Sub
Sub 条件付き書式再設定()
Sheets("返金メール送信履歴").Select
'条件付き書式を一旦全部削除
Cells.FormatConditions.Delete
'全キャンセル
Range("D2:L150").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND($D2=""送信済"",$E2=""★全キャンセル"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'一部返金（解除）
Range("D2:L150").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND($D2=""送信済"",$E2=""●一部返金"")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 16760576
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'一部返金（残し）
'Range("H2:O150").Select
' Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
' "=AND($G2=""送信済"",$H2=$C$30)"
' Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
' With Selection.FormatConditions(1).Interior
' .PatternColorIndex = xlAutomatic
' .Color = 3329330
' .TintAndShade = 0
' End With
'
' Selection.FormatConditions(1).StopIfTrue = False
'対応済
Range("D2:D150").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$D2=""対応済"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 32896
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'会員ID重複
Range("J:J").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'送信済
Range("D2:D150").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$D2=""送信済"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = 255
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Font
.ColorIndex = 2
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'コピー失敗
Range("B7:C7").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=B7:C7=""注文番号コピー失敗"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Font
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'重複する値 注文番号
Range("G:G").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'重複する値 伝票番号
Range("F:F").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A12").Select
End Sub
Sub コンシェメール作成()
Dim text1 As String, cbdata As New DataObject, name As String, store As String, date1 As String
Dim moji_count As Integer, mail As String
Dim arr1 As Variant
Dim i As Integer
'クリップボードから読み込み
cbdata.GetFromClipboard
text1 = cbdata.GetText
'text1 = Replace(text1, ChrW(12288), "") '全角スペースを削除
text1 = REPLACE(text1, ChrW(9), "") 'タブ区切りを削除
text1 = REPLACE(text1, ChrW(32), "") '半角スペースを削除
text1 = REPLACE(text1, vbCrLf, "") '改行を削除
'■で区切り
arr1 = Split(text1, "■")
'お客様名抜き出し
name = REPLACE(arr1(1), ChrW(12288), "") '全角スペースを削除
name = REPLACE(name, "お客様のお名前", "") & ChrW(32) & "様"
Range("B2").Value = name
'店舗抜出
store = REPLACE(arr1(5), "ご来店予定店舗", "")
Range("B3").Value = store
'予約日時抜き出し
Select Case Range("C4").Value
Case 1
date1 = REPLACE(arr1(6), "ご来店ご要望日時（第1希望）", "")
moji_count = InStr(date1, "～") - 1
date1 = Left(date1, moji_count)
Range("B4").Value = "第1希望"
Range("B5").Value = date1
Case 2
date1 = REPLACE(arr1(7), "ご来店ご要望日時（第2希望）", "")
moji_count = InStr(date1, "～") - 1
date1 = Left(date1, moji_count)
Range("B4").Value = "第2希望"
Range("B5").Value = date1
End Select
mail = Range("D2").Value & vbNewLine
'一行ずつ読み込む
For i = 1 To 36
mail = mail & Cells(i + 2, 4) & vbNewLine
Next i
'Range("D2:D38").Select
'Selection.Copy
'
''文字列の"を消す
'cbdata.GetFromClipboard
'mail = cbdata.GetText
'mail = Replace(mail, ChrW(34), "")
cbdata.SetText mail
cbdata.PutInClipboard
End Sub
Sub 口座情報連結()
Dim cbdata As New DataObject, STR As String, arr1 As Variant
Sheets("自動メール作成").Select
cbdata.GetFromClipboard
STR = cbdata.GetText
arr1 = Split(STR, vbCrLf)
STR = arr1(4) & " " & arr1(5) & " " & arr1(6) & " " & arr1(7) & " " & arr1(3) & " " & "返金額：" & arr1(0)
STR = REPLACE(STR, ChrW(12288), "") '全角スペースを削除
STR = REPLACE(STR, ChrW(9), "") 'タブ区切りを削除
Range("B21").Value = STR
cbdata.SetText STR
cbdata.PutInClipboard
End Sub
Sub クレカ系問い合わせのメールタイトル()
Dim cbdata As New DataObject, STR As String, str2 As String
Sheets("自動メール作成").Select
STR = "【ヨドバシ・ドット・コム】ご注文番号：●のカード決済につきまして"
cbdata.GetFromClipboard
STR = cbdata.GetText
STR = REPLACE(STR, "●", STR)
Range("B24").Value = STR
cbdata.SetText STR
cbdata.PutInClipboard
End Sub
Sub 口座情報連結2()
Sheets("自動メール作成").Select
Dim cbdata As New DataObject, STR As String, arr1 As Variant
cbdata.GetFromClipboard
STR = cbdata.GetText
STR = REPLACE(STR, ChrW(12288), "") '全角スペースを削除
STR = REPLACE(STR, ChrW(9), "") 'タブ区切りを削除
STR = REPLACE(STR, ChrW(32), "") '半角スペースを削除
arr1 = Split(STR, vbCrLf)
Dim bank As String, bank_code As String, store As String, store_code As String, koza As String, koza_num As String, name As String
Dim A As Byte, B As Byte, c As Byte, D As Byte, E As Byte
A = Len(arr1(0)) - 9
B = Len(arr1(1)) - 8
c = Len(arr1(2)) - 5
D = Len(arr1(3)) - 4
E = Len(arr1(4)) - 5
bank = Mid(arr1(0), 10, A)
bank_code = Mid(arr1(0), 6, 4)
store = Mid(arr1(1), 9, B)
store_code = Mid(arr1(1), 6, 3)
koza = Mid(arr1(2), 6, c)
koza_num = Mid(arr1(3), 5, 7)
name = Mid(arr1(4), 6, E)
STR = bank & "(" & bank_code & ")" & " " & store & "(" & store_code & ")" & " " & koza & " " & koza_num & " " & name
Range("B21").Value = STR
cbdata.SetText STR
cbdata.PutInClipboard
End Sub
Sub 銀行と支店番号入力()
Dim windowtitle As String, windowtitle1 As String
Dim bankcode As String, storecode As String
Dim wait_second As Integer
Dim cbdata As New DataObject
Dim den_num As String
Dim renban As String
Dim kouza_num As String
Dim meigi As String
Sheets("自動メール作成").Select
wait_second = 100
renban = Range("A36").Value
cbdata.GetFromClipboard
den_num = cbdata.GetText
den_num = Mid(den_num, 9, 10)
bankcode = Range("B34").Value
storecode = Range("B35").Value
'kouza_num = Range("B41").Value
'meigi = Range("B42").Value
windowtitle1 = "ECキャンセル返金先情報メンテナンス（変更）第一画面"
windowtitle = "ECキャンセル返金先情報メンテナンス（変更）入力画面"
AppActivate (windowtitle1)
Sleep 400
SendKeys (den_num)
Sleep wait_second
SendKeys "{F8}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep wait_second
SendKeys "{tab}"
Sleep wait_second
SendKeys (renban)
Sleep wait_second
SendKeys "{F8}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep 600
AppActivate (windowtitle)
Sleep wait_second
SendKeys (bankcode)
Sleep wait_second
SendKeys "{F8}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep wait_second
SendKeys "{TAB}"
Sleep wait_second
SendKeys (storecode)
Sleep wait_second
SendKeys "{F8}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep wait_second
SendKeys "{TAB}"
Sleep wait_second
If Range("B36") = "普通" Then
SendKeys (1)
Sleep wait_second
SendKeys "{F8}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep wait_second
SendKeys "{TAB}"
ElseIf Range("B36") = "当座" Then
SendKeys (2)
Sleep wait_second
SendKeys "{F8}"
Sleep wait_second
SendKeys "{ENTER}"
Sleep wait_second
SendKeys "{TAB}"
Else
MsgBox "口座種別エラー"
End If
Sleep wait_second
''口座番号入力
'SendKeys (kouza_num)
'Sleep wait_second
'SendKeys "{F8}"
'Sleep wait_second
'SendKeys "{ENTER}"
'Sleep wait_second
'SendKeys "{TAB}"
'Sleep wait_second
''口座名義入力 うまく動作しない・・
'
'SendKeys (meigi)
'Sleep wait_second
'SendKeys "{ENTER}"
'Sleep wait_second
'SendKeys "{TAB}"
'Sleep wait_second
SendKeys "{numlock}"
Sleep wait_second
SetCursorPos 47, 307
Sleep 50
mouse_event 2
mouse_event 4
Sleep 200
AppActivate ("Microsoft Excel - 業務用ノート.xlsm")
銀行番号入力アラート.Show
End Sub
Sub コンビニキャンセル()
Dim i As Integer
Dim n As Integer
Dim last_wait As Integer
Dim sleep_second As Integer
sleep_second = Range("B1").Value
last_wait = Range("B16").Value
n = Range("B2").Value
Sleep sleep_second
Range("D1").Value = "処理中"
For i = 1 To n
SetCursorPos Range("C5").Value, Range("D5").Value
Sleep sleep_second
mouse_event 2
mouse_event 4
Sleep sleep_second
SetCursorPos Range("C7").Value, Range("D7").Value
Sleep sleep_second
mouse_event 2
mouse_event 4
Sleep 1200
SendKeys "{ENTER}"
Sleep 1200
SetCursorPos Range("C10").Value, Range("D10").Value
Sleep sleep_second
mouse_event 2
mouse_event 4
Sleep sleep_second
SetCursorPos Range("C12").Value, Range("D12").Value
Sleep sleep_second
mouse_event 2
mouse_event 4
Sleep sleep_second
SendKeys "^s"
Sleep sleep_second
SendKeys "{ENTER}"
Sleep sleep_second
SendKeys "{ENTER}"
Sleep last_wait
Range("D1").Value = Range("B2").Value - i
If Range("D1").Value = 0 Then
Range("D1").Value = "処理完了"
End If
Next i
Sleep sleep_second
SendKeys "{numlock}"
End Sub
Sub カーソル位置取得()
Sleep 3000
Dim Cur As coordinate
GetCursorPos Cur
MsgBox "座標の位置：（X）" & Cur.x & "（Y）" & Cur.y
End Sub
Sub サプライ依頼クリア()
Range("K2:K10,L3,L4,L6,L7,L9,L10").ClearContents
End Sub
Sub 返金メール送信履歴クリア()
Worksheets("返金メール送信履歴").Select
Range("D2:L150").ClearContents
Call キャンセル内容式入力
Range("C1:C6").ClearContents
End Sub
Sub 自動メール送信済クリア()
Worksheets("自動メール送信済").Range("A2:H200").ClearContents
End Sub
Sub キャンセル内容式入力()
Range("E2").Formula = "=IF(H2<>"""",""●一部返金"","""")"
Range("E2").Select
Selection.Copy
Range("E3:E150").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Range("A12").Select
End Sub
Sub 返金エラー系伝票貼り付け()
Dim cbdata As New DataObject
Dim str1 As String
Dim den_num As String '受注番号
Dim order_num As String '注文番号
Dim den_name1 As String
Dim den_name2 As String
Dim den_code As String
Dim total_count As Integer
Dim list_count As Integer
Sheets("返金エラー系").Select
list_count = Range("E1").Value
cbdata.GetFromClipboard
str1 = cbdata.GetText
str1 = REPLACE(str1, ChrW(12288), "") '全角スペースを削除
str1 = REPLACE(str1, ChrW(9), "") 'タブ区切りを削除
str1 = REPLACE(str1, ChrW(32), "") '半角スペースを削除
str1 = REPLACE(str1, vbCrLf, "") '改行を削除
den_num = Mid(str1, 5, 10)
Cells(3 + list_count, 4).Value = den_num
order_num = Mid(str1, 41, 10)
Cells(3 + list_count, 5).Value = order_num
den_name1 = Mid(str1, InStr(str1, "名称(姓)／法人名") + 9, InStr(str1, "名称(名)／部署名") - InStr(str1, "名称(姓)／法人名") - 9)
den_name2 = Mid(str1, InStr(str1, "名称(名)／部署名") + 9, InStr(str1, "様〃") - InStr(str1, "名称(名)／部署名") - 9)
Cells(3 + list_count, 6).Value = den_name1 & " " & den_name2
End Sub
Sub 改行削除コピー()
Dim text As String, cbdata As New DataObject
cbdata.GetFromClipboard
text = cbdata.GetText
text = REPLACE(text, vbCrLf, "") '改行を削除
Range("B26").Value = text
With Range("B26")
.WrapText = False
.ShrinkToFit = True
End With
With cbdata
.SetText text
.PutInClipboard
End With
End Sub
Sub 名義コピー()
Dim text11 As String, cbdata As New DataObject
cbdata.GetFromClipboard
text11 = cbdata.GetText
text11 = REPLACE(text11, "-", "")
text11 = REPLACE(text11, "#", "")
text11 = REPLACE(text11, ">", "")
text11 = REPLACE(text11, "・", "")
text11 = REPLACE(text11, ":", "")
text11 = REPLACE(text11, "：", "")
text11 = REPLACE(text11, "口座名義(カタカナにてご記入ください)", "")
text11 = REPLACE(text11, "口座名義（カタカナ）", "")
text11 = REPLACE(text11, ChrW(12288), "") '全角スペースを削除
text11 = REPLACE(text11, ChrW(9), "") 'タブ区切りを削除
text11 = REPLACE(text11, ChrW(32), "") '半角スペースを削除
text11 = REPLACE(text11, vbCrLf, "") '改行を削除
text11 = "名義：" & text11
Range("B28").Value = text11
With Range("B28")
.WrapText = False
.ShrinkToFit = True
End With
With cbdata
.SetText text11
.PutInClipboard
End With
End Sub
Sub 不正連携抜出1()
Dim cbdata As New DataObject
Dim str1 As String
Dim arr1 As Variant
cbdata.GetFromClipboard
str1 = cbdata.GetText
str1 = REPLACE(str1, ChrW(12288), ChrW(32)) '全角スペースを半角スペースへ
str1 = REPLACE(str1, ChrW(9), ChrW(32)) 'タブ区切りを■へ
str1 = REPLACE(str1, vbCrLf, "") '改行を削除
str1 = REPLACE(str1, "受注受付日", "") '受注受付日を削除
str1 = REPLACE(str1, "*** キャンペーン対象 ***", "")
str1 = REPLACE(str1, "*** セット／クーポン受注 ***", "")
str1 = REPLACE(str1, "ﾏﾝｼｮﾝ･ﾋﾞﾙ名", "")
str1 = WorksheetFunction.Trim(str1)
str1 = REPLACE(str1, ChrW(32), "■") '半角スペースを■へ
arr1 = Split(str1, "■")
'Debug.Print str1
Cells(3 + Range("I1").Value, 1) = Date
'A列にデータが入力された時点で数値が１加算される為、B列以降は加算値を３→２に減らす。
Cells(2 + Range("I1").Value, 2) = arr1(1)
Cells(2 + Range("I1").Value, 3) = arr1(8)
Cells(2 + Range("I1").Value, 4) = arr1(21) & ChrW(32) & arr1(23)
Cells(2 + Range("I1").Value, 5) = arr1(27) & ChrW(32) & arr1(28)
Cells(2 + Range("I1").Value, 6) = "不正チェックT未連携"
End Sub
Sub 通常伝票抽出()
Dim cbdata As New DataObject, text1 As String
cbdata.GetFromClipboard
text1 = cbdata.GetText
text1 = REPLACE(text1, vbCrLf, "") '改行を削除
text1 = REPLACE(text1, ChrW(12288), ChrW(32)) '全角スペースを半角スペースへ
text1 = WorksheetFunction.Trim(text1)
text1 = REPLACE(text1, ChrW(32), "■") '半角スペースを■へ
Debug.Print text1
End Sub
Sub テスト()
Dim cbdata As New DataObject, i As Integer, text1 As String
text1 = Range("A1").Value & vbNewLine
For i = 1 To 5
text1 = text1 & Cells(i + 1, 1) & vbNewLine
Next i
cbdata.SetText text1
cbdata.PutInClipboard
End Sub
Sub 銀行番号取得クリップボード実行()
Dim cbdata As New DataObject
Dim outstr As String
On Error Resume Next
Sheets("自動メール作成").Select
Call 銀行番号取得クリップボード
Range("A40").Value = bankinfo_in
Range("A34").Value = bankname_out
Range("A35").Value = storename_out
Range("B34").Value = bankcode_out
Range("B35").Value = storecode_out
Range("B37").Value = bankname_kana_out
Range("B38").Value = storename_kana_out
On Error GoTo 0
If bankcode_out = "9900" Then
outstr = bankname_out & "(" & bankcode_out & ")" & vbCrLf & storename_out
Else
outstr = bankname_out & "(" & bankcode_out & ")" & vbCrLf & storename_out & "(" & storecode_out & ")"
End If
cbdata.SetText outstr
cbdata.PutInClipboard
End Sub
Sub 全銀サイトから貼付()
On Error Resume Next
Dim cbdata As New DataObject
Dim bankdata As String
Dim bankname As String
Dim bankname_kana As String
Dim bankcode As String
Dim storename As String
Dim storename_kana As String
Dim storecode As String
Dim str9 As String
Dim arr1() As String
cbdata.GetFromClipboard
bankdata = cbdata.GetText
bankdata = REPLACE(bankdata, vbCrLf, "")
bankdata = REPLACE(bankdata, ChrW(32), "")
bankdata = REPLACE(bankdata, ChrW(12288), "")
bankdata = REPLACE(bankdata, ChrW(9), "")
bankdata = REPLACE(bankdata, "金融機関名", "")
bankdata = REPLACE(bankdata, "フリガナ", "■")
bankdata = REPLACE(bankdata, "金融機関コード", "■")
bankdata = REPLACE(bankdata, "支店名", "■")
bankdata = REPLACE(bankdata, "支店コード", "■")
arr1() = Split(bankdata, "■")
bankname = arr1(0)
bankname_kana = arr1(1)
bankcode = arr1(2)
storename = arr1(3)
storename_kana = arr1(4)
storecode = arr1(5)
If bankcode = "9900" Then
str9 = bankname & "(" & bankcode & ")" & vbCrLf & storename
Else
str9 = bankname & "(" & bankcode & ")" & vbCrLf & storename & "(" & storecode & ")"
End If
Range("A34").Value = bankname
Range("A35").Value = storename
Range("B34").Value = bankcode
Range("B35").Value = storecode
Range("B37").Value = bankname_kana
Range("B38").Value = storename_kana
cbdata.SetText str9
cbdata.PutInClipboard
On Error GoTo 0
End Sub
Sub chrome起動()
Dim search_str As String
Dim googleurl As String
search_str = Range("A40").Value
search_str = search_str & "金融機関コード・銀行コード検索" '追加するキーワード
search_str = REPLACE(search_str, ChrW(32), "")
googleurl = "https://www.google.com/search?q="
Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & ChrW(32) & "--new-window" & ChrW(32) & googleurl & search_str
End Sub
Sub edge起動()
Dim wsh As IWshRuntimeLibrary.WshShell
Dim search_str As String
Dim googleurl As String
Set wsh = New IWshRuntimeLibrary.WshShell
search_str = Range("A40").Value
search_str = search_str & "金融機関コード・銀行コード検索" '追加するキーワード
search_str = REPLACE(search_str, ChrW(32), "")
googleurl = "https://www.google.com/search?q="
wsh.Run "msedge.exe -url " & ChrW(32) & googleurl & search_str
End Sub
Sub edge起動_コピーから()
Call 検索ワード貼付
Dim wsh As IWshRuntimeLibrary.WshShell
Dim search_str As String
Dim googleurl As String
Set wsh = New IWshRuntimeLibrary.WshShell
search_str = Range("A40").Value
search_str = search_str & "金融機関コード・銀行コード検索" '追加するキーワード
search_str = REPLACE(search_str, ChrW(32), "")
googleurl = "https://www.google.com/search?q="
wsh.Run "msedge.exe -url " & ChrW(32) & googleurl & search_str
End Sub
Sub 検索ワード貼付()
Dim cbdata As New DataObject
cbdata.GetFromClipboard
bankinfo_in = cbdata.GetText
'整形用テンプレ
'bankinfo_in = REPLACE(bankinfo_in, "★★", "")
bankinfo_in = REPLACE(bankinfo_in, vbCrLf, "")
bankinfo_in = REPLACE(bankinfo_in, "-", "")
bankinfo_in = REPLACE(bankinfo_in, "#", "")
bankinfo_in = REPLACE(bankinfo_in, ">", "")
bankinfo_in = REPLACE(bankinfo_in, "・", "")
bankinfo_in = REPLACE(bankinfo_in, ":", "")
bankinfo_in = REPLACE(bankinfo_in, "：", "")
bankinfo_in = REPLACE(bankinfo_in, "ご返金先銀行名", "")
bankinfo_in = REPLACE(bankinfo_in, "ご返金先支店名", "")
bankinfo_in = REPLACE(bankinfo_in, "返金先支店名", "")
bankinfo_in = REPLACE(bankinfo_in, "返金先銀行名", "")
bankinfo_in = REPLACE(bankinfo_in, "支店名", "")
bankinfo_in = REPLACE(bankinfo_in, "振込先銀行", "")
bankinfo_in = REPLACE(bankinfo_in, "銀行名", "")
bankinfo_in = REPLACE(bankinfo_in, "●", "")
bankinfo_in = REPLACE(bankinfo_in, ChrW(12288), ChrW(32))
bankinfo_in = REPLACE(bankinfo_in, ChrW(9), ChrW(32))
bankinfo_in = WorksheetFunction.Trim(bankinfo_in)
If InStr(bankinfo_in, ChrW(32)) = 0 Then
bankinfo_in = REPLACE(bankinfo_in, "銀行", "銀行 ")
bankinfo_in = REPLACE(bankinfo_in, "信用金庫", "信用金庫 ")
bankinfo_in = REPLACE(bankinfo_in, "信金", "信金 ")
bankinfo_in = REPLACE(bankinfo_in, "信用組合", "信用組合 ")
bankinfo_in = REPLACE(bankinfo_in, "信組", "信組 ")
bankinfo_in = REPLACE(bankinfo_in, "労働金庫", "労働金庫 ")
bankinfo_in = REPLACE(bankinfo_in, "労金", "労金 ")
bankinfo_in = REPLACE(bankinfo_in, "農業協同組合", "農業協同組合 ")
bankinfo_in = REPLACE(bankinfo_in, "農協", "農協 ")
End If
Range("A40").Value = bankinfo_in
bankinfo_in = ""
End Sub
- 前ページ
- 次ページ