Ｏffice編～Microsoft

Option Explicit
Dim zki As Long, zkiL As Long, zkRows As Long, zkRows1 As Long, zkRows2 As Long
Dim zkColumn As Long, zkColumn1 As Long, zkDayH As Long
Dim zkDate As Variant, zkDate1 As Variant
Dim zkAccount As String, zkUAccount As String, zkSheetN As String
Dim zksh As Shape, zkwsheet As Worksheet
Dim zkFoundCell As Range

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'タイム

'SendKeysキーで起きる-NUMLOCKをONにする
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, _
　ByVal bScan As Byte, _
　ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" _
　 (pbKeyState As Byte) As Long
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2

Sub アイコン整理01()

　　zkDate = Application.ClipboardFormats
　　If zkDate(1) = True Then
　　　　MsgBox "コピーデータは空です。", 48
　　　　Sheets("アイコン整理").Select
　　　　Range("A2").Select
　　　　End
　　End If
　　
　　If IMEStatus <> vbIMEModeOff Then 'IMEがひらがなだったら半角英数に切り替える
　　　　SendKeys "%{kanji}"
　　End If
　　
　　Call NUMLOCKをONにする 'SendKeysでNUMLOCKがOFFになるので
　　Sleep (100)
　　
　　zki = 0
p1:
　　zkDate = Application.InputBox( _
　　　　　　　　　　"アイコン貼付け先を入力してください。" & Chr(13) & _
　　　　　　　　　　"「ＲＴ」は　1" & Chr(13) & _
　　　　　　　　　　"「いいね」は　2　です。", Left:="30", Top:="10", Type:=1)　'数値で受けます Default:=2
　　
　　If TypeName(zkDate) = "Boolean" Then
　　　　Sheets("仮画像").Select
　　　　If ActiveSheet.Shapes.Count > 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Delete
　　　　End If
　　　　Sheets("アイコン整理").Select
　　　　Range("A2").Select
　　　　End '以後中止
　　ElseIf zkDate > 2 Then
　　　　zki = zki + 1
　　　　If zki = 3 Then
　　　　　　MsgBox "三回ミスしましたので終了します。", vbExclamation
　　　　　　Sheets("仮画像").Select
　　　　　　If ActiveSheet.Shapes.Count > 0 Then
　　　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　　　Selection.Delete
　　　　　　End If
　　　　　　Sheets("アイコン整理").Select
　　　　　　Range("A2").Select
　　　　　　End '以後中止
　　　　Else
　　　　　　MsgBox "「ＲＴ」は　1、「いいね」は　2　で入力して下さい。", vbExclamation
　　　　　　GoTo p1 'p1:の構文まで戻ります
　　　　End If
　　End If
　　
　　zki = 0
p2:
　　zkDate1 = Application.InputBox( _
　　　　　　　　　　"「日にち」だけを入力してください。", Type:=1, Left:="30", Top:="50") '数値で受けます

　　If TypeName(zkDate1) = "Boolean" Then
　　　　Sheets("仮画像").Select
　　　　If ActiveSheet.Shapes.Count > 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Delete
　　　　End If
　　　　Sheets("アイコン整理").Select
　　　　Range("A2").Select
　　　　End '以後中止
　　ElseIf zkDate1 > 31 Then
　　　　zki = zki + 1
　　　　If zki = 3 Then
　　　　　　MsgBox "三回ミスしましたので終了します。", vbExclamation
　　　　　　Sheets("仮画像").Select
　　　　　　If ActiveSheet.Shapes.Count > 0 Then
　　　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　　　Selection.Delete
　　　　　　End If
　　　　　　Sheets("アイコン整理").Select
　　　　　　Range("A2").Select
　　　　　　End '以後中止
　　　　Else
　　　　　　MsgBox "6/12場合は　12　だけを入力して下さい。", vbExclamation
　　　　　　GoTo p2 'p2:の構文まで戻ります
　　　　End If
　　End If
　　
　　Application.ScreenUpdating = False '画面更新を停止する
　　Sheets("仮画像").Select
　　Range("A2").Select
　　ActiveSheet.Paste
　　DoEvents
　　Sleep (500) '(500)
　　DoEvents
　　Columns("A").Select
　　Selection.ClearContents
　　
　　'不要な画像を削除。Microsoft Edge・Google Chromeで確認済みです。
　　With Worksheets("仮画像")
　　　　For zki = .Shapes.Count To 1 Step -1
　　　　　　If .Shapes(zki).Width = 24 Then .Shapes(zki).Delete　'画像のWidth 24を削除
　　　　Next zki
　　End With
　　
　　Sheets("仮画像").Select
　　If ActiveSheet.Shapes.Count = 0 Then
　　　　MsgBox "アイコンのコピーが有りません1。", 48
　　　　Columns("A").Select
　　　　Selection.ClearContents
　　　　Sheets("アイコン整理").Select
　　　　Range("A2").Select
　　　　Application.ScreenUpdating = True '画面更新を許可する
　　　　End '画像がなければ終了
　　End If
　　
　　Sheets("仮画像").Select '画像の大きさ調整
　　ActiveSheet.DrawingObjects.Select
　　Selection.ShapeRange.Height = 26
　　Range("A1").Select
　　
　　Call アイコン整理02

End Sub
Sub アイコン整理02()

　　Sheets("仮画像").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　
　　　　Columns("F").Select
　　　　Selection.ClearContents
　　　　Range("F1").Select
　　　　Set zkwsheet = ActiveSheet
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　For Each zksh In zkwsheet.Shapes
　　　　　If zksh.Type = msoPicture Then
　　　　　　　If zksh.Hyperlink.Address = "" Then zksh.Delete '画像にハイパーリンク無削除
　　　　　End If
　　　　Next
　　　　On Error GoTo 0
　　　　
　　End If

　　zkRows = 2
　　Sheets("仮画像").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　
　　　　Columns("F").Select
　　　　Selection.ClearContents
　　　　Range("F1").Select
　　　　Set zkwsheet = ActiveSheet
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　For Each zksh In zkwsheet.Shapes
　　　　　If zksh.Type = msoPicture Then
　　　　　　　zksh.Name = Mid(zksh.Hyperlink.Address, 21) '画像に名前を付ける
　　　　　　　If Sheets("仮画像").Range("F" & zkRows - 1).Value = zksh.Name Then
　　　　　　　　zksh.Delete 'ダブった画像を削除
　　　　　　　Else
　　　　　　　　Sheets("仮画像").Range("F" & zkRows).Value = zksh.Name　 '画像名を書き出す
　　　　　　　　zkRows = zkRows + 1
　　　　　　　End If
　　　　　End If
　　　　Next
　　　　On Error GoTo 0
　　　　
　　End If

　　Call アイコン整理03
　　
End Sub
Sub アイコン整理03()
　　
　　Sheets("アイコン整理").Select
　　zkAccount = Range("C3").Value
　　zki = Len(zkAccount)
　　zkRows = 2
　　Do
　　　　
　　　　Sheets("仮画像").Select
　　　　If Mid(Range("F" & zkRows).Value, 1, zki) = zkAccount Then 'アカウト名が有る画像名を削除する
　　　　　　zkUAccount = Range("F" & zkRows).Value
　　　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　　　Sheets("仮画像").Select
　　　　　　Range("A1").Select
　　　　　　ActiveSheet.Shapes(zkUAccount).Select '自分の画像が混ざっていないか確認
　　　　　　If Err.Number = 0 Then
　　　　　　　　Selection.Name = zkUAccount
　　　　　　　　Selection.Delete '自分の画像を削除する
　　　　　　End If
　　　　　　On Error GoTo 0
　　　　　　Range("F" & zkRows).Select
　　　　　　Selection.Delete Shift:=xlUp
　　　　　　zkRows = zkRows - 1
　　　　End If
　　　　zkRows = zkRows + 1
　　　　
　　Loop Until Sheets("仮画像").Range("F" & zkRows).Value = ""

　　zkRows = 2
　　Do
　　　　
　　　　Sheets("仮画像").Select
　　　　If Len(Range("F" & zkRows).Value) > 15 Then 'アカウト名が15文字以上の場合削除
　　　　　　zkAccount = Range("F" & zkRows).Value
　　　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　　　Sheets("仮画像").Select
　　　　　　Range("A1").Select
　　　　　　ActiveSheet.Shapes(zkAccount).Select 'アカウト名が15文字以上の画像が混ざっていないか確認
　　　　　　If Err.Number = 0 Then
　　　　　　　　Selection.Name = zkAccount
　　　　　　　　Selection.Delete '画像を削除する
　　　　　　End If
　　　　　　On Error GoTo 0
　　　　　　Range("F" & zkRows).Select
　　　　　　Selection.Delete Shift:=xlUp
　　　　　　zkRows = zkRows - 1
　　　　End If
　　　　zkRows = zkRows + 1
　　　　
　　Loop Until Sheets("仮画像").Range("F" & zkRows).Value = ""
　
　　Sheets("仮画像").Select
　　If ActiveSheet.Shapes.Count > 30 Then
　　　　MsgBox "アイコンのコピーが「30アカウント」を超えました。" & Chr(13) & _
　　　　"再度、20以内のコピーして下さい。", 48
　　　　ActiveSheet.DrawingObjects.Select
　　　　Selection.Delete
　　　　Columns("A:D").Select
　　　　Selection.ClearContents
　　　　Range("F1").Select
　　　　Sheets("アイコン整理").Select
　　　　Range("A2").Select
　　　　Application.ScreenUpdating = True '画面更新を許可する
　　　　End '画像がなければ終了
　　End If
　　
　　Call アイコン整理04
　　
End Sub
Sub アイコン整理04()

　　zkDayH = Day(Sheets("アイコン整理").Range("C5").Value)　 '整理する日
　　zkSheetN = ""
　　
　　If zkDate = 1 Then '「RT」「いいね」を区別
　　　　If zkDate1 = zkDayH Then　'「本日RT」「前日RT」を区別してシート名を決める
　　　　　 zkSheetN = "当日RT"
　　　　Else
　　　　　　zkSheetN = "前日RT"
　　　　End If
　　Else
　　　　If zkDate1 = zkDayH Then　'「本日いいね」「前日いいね」を区別してシート名を決める
　　　　　 zkSheetN = "当日いいね"
　　　　Else
　　　　　　zkSheetN = "前日いいね"
　　　　End If
　　End If
　
　　Sheets("仮画像").Select
　　If Range("F2").Value = "" Then
　　　　MsgBox "整理するアイコンが有りません。"
　　　　Sheets("アイコン整理").Select
　　　　Range("A1").Select
　　　　Application.ScreenUpdating = True '画面更新を許可する
　　　　End '画像名の書き出しが無ければ終了
　　Else
　　　　If zkDate1 = zkDayH Then
　　　　　　zkRows = 2
　　　　　　Do
　　　　　　　　Sheets("仮画像").Select
　　　　　　　　zkAccount = Range("F" & zkRows).Value
　　　　　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　　　　　　　Sheets(zkSheetN).Select '★
　　　　　　　　　　Range("A1").Select
　　　　　　　　　　ActiveSheet.Shapes(zkAccount).Select
　　　　　　　　　　If Err.Number = 0 Then
　　　　　　　　　　　　Sheets("仮画像").Select '★
　　　　　　　　　　　　Range("A1").Select
　　　　　　　　　　　　ActiveSheet.Shapes(zkAccount).Select
　　　　　　　　　　　　Selection.Delete 'アイコン削除
　　　　　　　　　　End If
　　　　　　　　On Error GoTo 0
　　　　　　　　zkRows = zkRows + 1
　　　　　　Loop Until Sheets("仮画像").Range("F" & zkRows).Value = ""
　　　　End If
　　End If
　　
　　Sheets("仮画像").Select
　　zkRows = 2
　　zkRows1 = 2
　　zkColumn = 2
　　Do
　　　　zkAccount = Range("F" & zkRows).Value
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　　　ActiveSheet.Shapes(zkAccount).Select
　　　　　　If Err.Number = 0 Then
　　　　　　　　Selection.Name = zkAccount
　　　　　　　　Selection.Cut '切り取り
　　　　　　　　Sheets("仮画像").Select 'シートB～D列に並べる
　　　　　　　　Cells(zkRows1, zkColumn).Value = "G"
　　　　　　　　Cells(zkRows1, zkColumn).Select
　　　　　　　　ActiveSheet.Paste
　　　　　　　　Application.CutCopyMode = False
　　　　　　　　If zkRows1 = 11 Then
　　　　　　　　　　zkColumn = zkColumn + 1
　　　　　　　　　　zkRows1 = 2
　　　　　　　　Else
　　　　　　　　　　zkRows1 = zkRows1 + 1
　　　　　　　　End If
　　　　　　End If
　　　　On Error GoTo 0
　　　　zkRows = zkRows + 1
　　Loop Until Sheets("仮画像").Range("F" & zkRows).Value = ""
　　
　　Range("A1").Select
　　
　　Sheets(zkSheetN).Select '画像追加シート
　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　For zki = 1 To 5
　　　　Range("A1").Select
　　　　Set zkFoundCell = Cells.Find(What:=zkDate1, LookAt:=xlWhole)
　　　　If zkFoundCell Is Nothing Then
　　　　　　Exit For
　　　　Else
　　　　　　zkFoundCell.Select
　　　　　　Selection.Delete Shift:=xlUp '前の入力日を削除
　　　　　　Sleep (500)
　　　　End If
　　Next zki
　　On Error GoTo 0
　　
　　For zkiL = 1 To 3
　　　　
　　　　　　Sheets("仮画像").Select '画像元シート
　　　　　　If ActiveSheet.Shapes.Count = 0 Then '画像の有無確認
　　　　　　　Exit For
　　　　　　Else
　　　　　　　　
　　　　　　　　Sheets(zkSheetN).Select '画像追加シート
　　　　　　　　zkRows = 0
　　　　　　　　zkRows1 = 500 '行最大値（１行10画像）
　　　　　　　　zkColumn = 1
　　　　　　　　For zki = 10 To 1 Step -1 '１０列目から逆に画像貼り付け位置確認
　　　　　　　　
　　　　　　　　　　zkRows = Cells(Rows.Count, zki).End(xlUp).Row
　　　　　　　　　　If zkRows1 > zkRows Then
　　　　　　　　　　　　zkRows1 = zkRows + 1
　　　　　　　　　　　　zkColumn = zki
　　　　　　　　　　End If
　　　　　　　　　　
　　　　　　　　Next zki
　　　　　　　　
　　　　　　　　Sheets("仮画像").Select '画像元シート
　　　　　　　　Range(Cells(2, zkiL + 1), Cells(11, zkiL + 1)).Select
　　　　　　　　Selection.Cut '切り取り
　　　　　　　　Sheets(zkSheetN).Select '画像追加シート
　　　　　　　　Cells(zkRows1, zkColumn).Value = zkDate1 '日にちを入力
　　　　　　　　Cells(zkRows1 + 1, zkColumn).Select
　　　　　　　　ActiveSheet.Paste
　　　　　　　　Application.CutCopyMode = False
　　　　　　　　If zkiL = 1 Then '最初の画像貼り付け位置
　　　　　　　　　　zkRows2 = zkRows1
　　　　　　　　　　zkColumn1 = zkColumn
　　　　　　　　End If
　　　　　　　　
　　　　　　End If
　　　　
　　Next zkiL
　　
　　Sheets("アイコン整理").Select
　　Range("A2").Select
　　
　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　Sheets(zkSheetN).Select
　　Cells(zkRows2, zkColumn1).Select
　　On Error GoTo 0
　　
　　ThisWorkbook.Save
　　Sleep (2000)
　　Application.ScreenUpdating = True '画面更新を許可する
　　
End Sub
Function NUMLOCKをONにする()

　　Dim NumLockState As Boolean
　　Dim keys(0 To 255) As Byte
　　GetKeyboardState keys(0)
　　NumLockState = keys(VK_NUMLOCK)
　　　
　　If NumLockState <> True Then 'オフであれば強制的にオンにする
　　　　keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
　　　　keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
　　End If
　　
End Function

Option Explicit
Dim zki As Long, zkiL As Long, zkRows As Long, zkRows1 As Long, zkRows2 As Long, zkRowsL As Long
Dim zkColumn As Long, zkColumn1 As Long, zkmsg As Long, zkDayH As Long, zkDayZ As Long
Dim zkDate As Variant, zkDate1 As Variant, zkDate2 As Variant, zkDate3 As Variant
Dim zkAccount As String, zkUAccount As String, zkSheetN As String
Dim zksh As Shape, zkwsheet As Worksheet
Dim zkFoundCell As Range
Sub 前日RT整理()
　　
　　zkDate = CDate(Sheets("アイコン整理").Range("C5").Value) '基準日付
　　zkDayH = Day(zkDate) '基準日にち
　　
　　zkSheetN = "前日RT" '一番目に整理するシート
　　
　　Sheets("仮シート").Select
　　Columns("A:B").Select
　　Selection.ClearContents
　　Range("A1").Select
　　Sheets(zkSheetN).Select
　　Range("A1").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　
　　　　Set zkwsheet = ActiveSheet '画像の名前とハイパーリンクを書き出す
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　For Each zksh In zkwsheet.Shapes
　　　　　　Sheets("仮シート").Range("A65536").End(xlUp).Offset(1) = zksh.Hyperlink.Address
　　　　　　Sheets("仮シート").Range("B65536").End(xlUp).Offset(1) = zksh.Name
　　　　Next
　　　　On Error GoTo 0
　　　　
　　　　Sheets("仮シート").Select
　　　　If Sheets("仮シート").Range("A1").Value = "" Then
　　　　　　Rows("1:1").Select
　　　　　　Selection.Delete Shift:=xlUp
　　　　End If
　　　　
　　　　Sheets("仮シート").Select
　　　　Range("A1").Select
　　　　Selection.CurrentRegion.Select
　　　　zkRowsL = Selection.Rows.Count
　　　　
　　　　Sheets("仮シート").Select 'この構文は前日分にのみ「L」まで
　　　　Worksheets("仮シート").Range("A1:B" & zkRowsL) _
　　　　　　 .Sort Key1:=Range("B1"), order1:=xlAscending 'xlDescending は降順に並べ替えます
　　　　　　
　　　　zkRows = 2
　　　　Do 'ダブっているアカウトを一つにする
　　　　　　If Cells(zkRows - 1, 2).Value = Cells(zkRows, 2).Value Then
　　　　　　　　Rows(zkRows & ":" & zkRows).Select
　　　　　　　　Selection.Delete Shift:=xlUp
　　　　　　　　zkRows = zkRows - 1
　　　　　　End If
　　　　　　zkRows = zkRows + 1
　　　　Loop Until Cells(zkRows, 1) = ""
　　
　　End If
　　
　　If Sheets("仮シート").Range("B1").Value <> "" Then
　　
　　　　zkRows = 1
　　　　zkRows1 = 0
　　　　Do
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　zkRowsL = Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　　　　
　　　　　　zkAccount = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　
　　　　　　Set zkFoundCell = Range("B:B").Find(What:=zkAccount) 'アカウント検索
　　　　　　
　　　　　　If zkFoundCell Is Nothing Then 'アカウント検索の有無
　　　　　　
　　　　　　　　Sheets("クリック確認").Select
　　　　　　　　Range("A" & zkRowsL).Value = Sheets("仮シート").Range("A" & zkRows).Value
　　　　　　　　Range("B" & zkRowsL).Value = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　　　Range("C" & zkRowsL).Value = zkDate - 1
　　　　　　　　Range("D" & zkRowsL).Value = 1

　　　　　　Else
　　　　　　　　zkFoundCell.Activate
　　　　　　　　zkRows1 = ActiveCell.Row
　　　　　　　　If Range("C" & zkRows1).Value < zkDate - 1 Then
　　　　　　　　　　Range("C" & zkRows1).Value = zkDate - 1
　　　　　　　　　　Range("D" & zkRows1).Value = Range("D" & zkRows1).Value + 1
　　　　　　　　End If
　　　　　　End If
　　　　　　
　　　　　　zkRows = zkRows + 1
　　　　　　
　　　　Loop Until Sheets("仮シート").Range("B" & zkRows).Value = ""
　　End If
　　
　　Call 前日いいね整理
　　
End Sub
Sub 前日いいね整理()
　　
　　zkDate = CDate(Sheets("アイコン整理").Range("C5").Value) '基準日付
　　zkDayH = Day(zkDate) '基準日にち
　　
　　zkSheetN = "前日いいね" '二番目に整理するシート
　　
　　Sheets("仮シート").Select
　　Columns("A:B").Select
　　Selection.ClearContents
　　Range("A1").Select
　　Sheets(zkSheetN).Select
　　Range("A1").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　
　　　　Set zkwsheet = ActiveSheet '画像の有無、無い場合は以後構文を終了する
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　For Each zksh In zkwsheet.Shapes
　　　　　　Sheets("仮シート").Range("A65536").End(xlUp).Offset(1) = zksh.Hyperlink.Address
　　　　　　Sheets("仮シート").Range("B65536").End(xlUp).Offset(1) = zksh.Name
　　　　Next
　　　　On Error GoTo 0
　　　　
　　　　Sheets("仮シート").Select
　　　　If Sheets("仮シート").Range("A1").Value = "" Then
　　　　　　Rows("1:1").Select
　　　　　　Selection.Delete Shift:=xlUp
　　　　End If
　　　　
　　　　Sheets("仮シート").Select
　　　　Range("A1").Select
　　　　Selection.CurrentRegion.Select
　　　　zkRowsL = Selection.Rows.Count
　　　　
　　　　Sheets("仮シート").Select 'この構文は前日分にのみ「L」まで
　　　　Worksheets("仮シート").Range("A1:B" & zkRowsL) _
　　　　　　 .Sort Key1:=Range("B1"), order1:=xlAscending 'xlDescending は降順に並べ替えます
　　　　　　
　　　　zkRows = 2
　　　　Do 'ダブっているアカウトを一つにする
　　　　　　If Cells(zkRows - 1, 2).Value = Cells(zkRows, 2).Value Then
　　　　　　　　Rows(zkRows & ":" & zkRows).Select
　　　　　　　　Selection.Delete Shift:=xlUp
　　　　　　　　zkRows = zkRows - 1
　　　　　　End If
　　　　　　zkRows = zkRows + 1
　　　　Loop Until Cells(zkRows, 1) = ""
　　
　　End If
　　
　　If Sheets("仮シート").Range("B1").Value <> "" Then
　　
　　　　zkRows = 1
　　　　zkRows1 = 0
　　　　Do
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　zkRowsL = Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　　　　
　　　　　　zkAccount = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　
　　　　　　Set zkFoundCell = Range("B:B").Find(What:=zkAccount) 'アカウント検索
　　　　　　
　　　　　　If zkFoundCell Is Nothing Then 'アカウント検索の有無
　　　　　　
　　　　　　　　Sheets("クリック確認").Select
　　　　　　　　Range("A" & zkRowsL).Value = Sheets("仮シート").Range("A" & zkRows).Value
　　　　　　　　Range("B" & zkRowsL).Value = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　　　Range("E" & zkRowsL).Value = zkDate - 1
　　　　　　　　Range("F" & zkRowsL).Value = 1

　　　　　　Else
　　　　　　　　zkFoundCell.Activate
　　　　　　　　zkRows1 = ActiveCell.Row
　　　　　　　　If Range("E" & zkRows1).Value < zkDate - 1 Then
　　　　　　　　　　Range("E" & zkRows1).Value = zkDate - 1
　　　　　　　　　　Range("F" & zkRows1).Value = Range("D" & zkRows1).Value + 1
　　　　　　　　End If
　　　　　　End If
　　　　　　
　　　　　　zkRows = zkRows + 1
　　　　　　
　　　　Loop Until Sheets("仮シート").Range("B" & zkRows).Value = ""
　　End If
　　
　　Call 月初め
　　
End Sub
Sub 月初め()

　'この処理はExcelを出来るだけ軽くするための処理です
　'毎月１日のまとめ時に一ヶ月以前のデータを削除して「RT計]と「いいね計」を総合計に加算し、計を0にする
　
　　zkDate = Format(CDate(Sheets("アイコン整理").Range("C5").Value), "d") '基準日付
　　zkDate1 = DateAdd("m", -1, Date)

　　If zkDate = 1 Then

　　　　Sheets("クリック確認").Select
　　　　Columns("A:H").Select
　　　　Selection.Copy
　　　　Range("L1").Select
　　　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　　　:=False, Transpose:=False
　　　　Range("A1").Select
　　　　Application.CutCopyMode = False
　
　　　　zkRows = 2
　　　　
　　　　Do
　　　　　　Sheets("クリック確認").Select
　　　　　　If CDbl(Range("C" & zkRows).Value) < zkDate1 Then
　　　　　　　　If CDbl(Range("E" & zkRows).Value) < zkDate1 Then
　　　　　　　　　　Rows(zkRows & ":" & zkRows).Select
　　　　　　　　　　Selection.Delete Shift:=xlUp
　　　　　　　　　　zkRows = zkRows - 1
　　　　　　　　End If
　　　　　　End If
　　　　　　zkRows = zkRows + 1
　　　　Loop Until Sheets("クリック確認").Range("A" & zkRows).Value = ""
　　　　
　　　　zkRows = 2
　　　　Do
　　　　　　Sheets("クリック確認").Range("G" & zkRows).Value = Sheets("クリック確認").Range("G" & zkRows).Value + Sheets("クリック確認").Range("D" & zkRows).Value
　　　　　　Sheets("クリック確認").Range("H" & zkRows).Value = Sheets("クリック確認").Range("H" & zkRows).Value + Sheets("クリック確認").Range("F" & zkRows).Value
　　　　　　Sheets("クリック確認").Range("D" & zkRows).Value = ""
　　　　　　Sheets("クリック確認").Range("F" & zkRows).Value = ""
　　　　　　zkRows = zkRows + 1
　　　　Loop Until Sheets("クリック確認").Range("A" & zkRows).Value = ""
　　　　
　　End If
　　
　　Sheets("クリック確認").Select
　　Range("A1").Select
　　
　　Call 当日RT整理

End Sub
Sub 当日RT整理()
　　
　　zkDate = CDate(Sheets("アイコン整理").Range("C5").Value) '基準日付
　　zkDayH = Day(zkDate) '基準日にち
　　
　　zkSheetN = "当日RT" '三番目に整理するシート
　　
　　Sheets("仮シート").Select
　　Columns("A:B").Select
　　Selection.ClearContents
　　Range("A1").Select
　　Sheets(zkSheetN).Select
　　Range("A1").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　
　　　　Set zkwsheet = ActiveSheet '画像の有無、無い場合は以後構文を終了する
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　For Each zksh In zkwsheet.Shapes
　　　　　　Sheets("仮シート").Range("A65536").End(xlUp).Offset(1) = zksh.Hyperlink.Address
　　　　　　Sheets("仮シート").Range("B65536").End(xlUp).Offset(1) = zksh.Name
　　　　Next
　　　　On Error GoTo 0
　　　　
　　　　Sheets("仮シート").Select
　　　　If Sheets("仮シート").Range("A1").Value = "" Then
　　　　　　Rows("1:1").Select
　　　　　　Selection.Delete Shift:=xlUp
　　　　End If
　　　　
　　End If
　　
　　If Sheets("仮シート").Range("B1").Value <> "" Then
　　
　　　　zkRows = 1
　　　　zkRows1 = 0
　　　　Do
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　zkRowsL = Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　　　　
　　　　　　zkAccount = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　
　　　　　　Set zkFoundCell = Range("B:B").Find(What:=zkAccount) 'アカウント検索
　　　　　　
　　　　　　If zkFoundCell Is Nothing Then 'アカウント検索の有無
　　　　　　
　　　　　　　　Sheets("クリック確認").Select
　　　　　　　　Range("A" & zkRowsL).Value = Sheets("仮シート").Range("A" & zkRows).Value
　　　　　　　　Range("B" & zkRowsL).Value = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　　　Range("C" & zkRowsL).Value = zkDate
　　　　　　　　Range("D" & zkRowsL).Value = 1

　　　　　　Else

　　　　　　　　zkFoundCell.Activate
　　　　　　　　zkRows1 = ActiveCell.Row
　　　　　　　　Range("C" & zkRows1).Value = zkDate
　　　　　　　　Range("D" & zkRows1).Value = Range("D" & zkRows1).Value + 1
　　　　　　　　
　　　　　　End If
　　　　　　
　　　　　　zkRows = zkRows + 1
　　　　　　
　　　　Loop Until Sheets("仮シート").Range("B" & zkRows).Value = ""
　　End If
　　
　　Call 当日いいね整理
　　
End Sub
Sub 当日いいね整理()

　　Application.ScreenUpdating = False '画面更新を停止する
　　
　　zkDate = CDate(Sheets("アイコン整理").Range("C5").Value) '基準日付
　　zkDayH = Day(zkDate) '基準日にち
　　
　　zkSheetN = "当日いいね" '四番目に整理するシート
　　
　　Sheets("仮シート").Select
　　Columns("A:B").Select
　　Selection.ClearContents
　　Range("A1").Select
　　Sheets(zkSheetN).Select
　　Range("A1").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　
　　　　Set zkwsheet = ActiveSheet '画像の有無、無い場合は以後構文を終了する
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　For Each zksh In zkwsheet.Shapes
　　　　　　Sheets("仮シート").Range("A65536").End(xlUp).Offset(1) = zksh.Hyperlink.Address
　　　　　　Sheets("仮シート").Range("B65536").End(xlUp).Offset(1) = zksh.Name
　　　　Next
　　　　On Error GoTo 0
　　　　
　　　　Sheets("仮シート").Select
　　　　If Sheets("仮シート").Range("A1").Value = "" Then
　　　　　　Rows("1:1").Select
　　　　　　Selection.Delete Shift:=xlUp
　　　　End If
　　
　　End If
　　
　　If Sheets("仮シート").Range("B1").Value <> "" Then
　　
　　　　zkRows = 1
　　　　zkRows1 = 0
　　　　Do
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　zkRowsL = Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　　　　
　　　　　　zkAccount = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　
　　　　　　Sheets("クリック確認").Select
　　　　　　Range("B1").Select
　　　　　　
　　　　　　Set zkFoundCell = Range("B:B").Find(What:=zkAccount) 'アカウント検索
　　　　　　
　　　　　　If zkFoundCell Is Nothing Then 'アカウント検索の有無
　　　　　　
　　　　　　　　Sheets("クリック確認").Select
　　　　　　　　Range("A" & zkRowsL).Value = Sheets("仮シート").Range("A" & zkRows).Value
　　　　　　　　Range("B" & zkRowsL).Value = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　　　Range("E" & zkRowsL).Value = zkDate
　　　　　　　　Range("F" & zkRowsL).Value = 1

　　　　　　Else

　　　　　　　　zkFoundCell.Activate
　　　　　　　　zkRows1 = ActiveCell.Row
　　　　　　　　Range("E" & zkRows1).Value = zkDate
　　　　　　　　Range("F" & zkRows1).Value = Range("F" & zkRows1).Value + 1
　　　　　　　　
　　　　　　End If
　　　　　　
　　　　　　zkRows = zkRows + 1
　　　　　　
　　　　Loop Until Sheets("仮シート").Range("B" & zkRows).Value = ""
　　End If
　　
　　Sheets("仮シート").Select
　　Columns("A:B").Select
　　Selection.ClearContents
　　
　　Sheets("クリック確認").Select 'データを並び替える
　　Range("A1").Select
　　Selection.CurrentRegion.Select
　　zkRowsL = Selection.Rows.Count
　　
　　ActiveWorkbook.Worksheets("クリック確認").Sort.SortFields.Clear
　　ActiveWorkbook.Worksheets("クリック確認").Sort.SortFields.Add Key:=Range("C2:C" & zkRowsL _
　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　ActiveWorkbook.Worksheets("クリック確認").Sort.SortFields.Add Key:=Range("D2:D" & zkRowsL _
　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　ActiveWorkbook.Worksheets("クリック確認").Sort.SortFields.Add Key:=Range("E2:E" & zkRowsL _
　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　ActiveWorkbook.Worksheets("クリック確認").Sort.SortFields.Add Key:=Range("F2:F" & zkRowsL _
　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　With ActiveWorkbook.Worksheets("クリック確認").Sort
　　　　 .SetRange Range("A1:H" & zkRowsL)
　　　　 .Header = xlYes
　　　　 .MatchCase = False
　　　　 .Orientation = xlTopToBottom
　　　　 .SortMethod = xlPinYin
　　　　 .Apply
　　 End With
　　
　　 Sheets("クリック確認").Select
　　With ActiveSheet.Hyperlinks
　　　　For zki = 2 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　 .Add Anchor:=Cells(zki, "A"), Address:=Cells(zki, "A").Value
　　　　Next zki
　　End With
　　
　　Call RTアイコン整理
　　
End Sub
Sub RTアイコン整理()

　　zkDate = CDate(Sheets("アイコン整理").Range("C5").Value) '基準日付
　　
　　Sheets("RT").Select
　　Columns("A").Select
　　Selection.ClearContents
　　Range("A1").Select
　　
　　Sheets("仮シート").Select
　　Cells.Font.Size = 11
　　Sheets("仮シート").Select
　　Columns("A:E").Select
　　Selection.ClearContents
　　Range("A1").Select
　　
　　Sheets("クリック確認").Select '基準日付の三日前までのデータから「RT」シートにアイコンを並べる」
　　
　　zkRows = 0
　　
　　Set zkFoundCell = Range("C:C").Find(What:=Format(zkDate - 3, "yyyy/mm/dd"), LookIn:=xlValues) '日付を検索
　　
　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　If zkFoundCell Is Nothing Then '日付検索の有無
　　　　zkRows = Cells(Rows.Count, 3).End(xlUp).Row
　　Else
　　　　zkFoundCell.Activate
　　　　zkRows = ActiveCell.Row - 1
　　End If
　　On Error GoTo 0
　　
　　If zkRows > 1 Then '日付検索の有り場合実行
　　　　Range("B2" & ":G" & zkRows).Select
　　　　Selection.Copy
　　　　Range("A1").Select
　　　　Sheets("仮シート").Select
　　　　Range("A1").PasteSpecial Paste:=xlValues
　　　　Application.CutCopyMode = False
　　　　Columns("D:E").Select
　　　　Selection.Delete Shift:=xlToLeft
　　　　Range("A1").Select
　　　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Clear
　　　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Add Key:=Range("B1:B" & zkRows - 1 _
　　　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Add Key:=Range("C1:C" & zkRows - 1 _
　　　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Add Key:=Range("D1:D" & zkRows - 1 _
　　　　　　), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　　　With ActiveWorkbook.Worksheets("仮シート").Sort
　　　　　　 .SetRange Range("A1:D" & zkRows - 1)
　　　　　　 .Header = xlGuess
　　　　　　 .MatchCase = False
　　　　　　 .Orientation = xlTopToBottom
　　　　　　 .SortMethod = xlPinYin
　　　　　　 .Apply
　　　　End With
　　　　
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　Sheets("当日RT").Select '画像を[仮シート]に移す
　　　　Columns("A:J").Select
　　　　Selection.ClearContents
　　　　Range("A1").Select
　　　　If ActiveSheet.Shapes.Count <> 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Cut '切り取り
　　　　　　Sheets("仮シート").Select
　　　　　　Range("G1").Select
　　　　　　ActiveSheet.Paste
　　　　　　Application.CutCopyMode = False
　　　　End If
　　　　
　　　　Sheets("前日RT").Select '画像を[仮シート]に移す
　　　　Columns("A:J").Select
　　　　Selection.ClearContents
　　　　Range("A1").Select
　　　　If ActiveSheet.Shapes.Count <> 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Cut '切り取り
　　　　　　Sheets("仮シート").Select
　　　　　　Range("L1").Select
　　　　　　ActiveSheet.Paste
　　　　　　Application.CutCopyMode = False
　　　　End If
　　　　
　　　　Sheets("RT").Select '画像を[仮シート]に移す
　　　　Columns("A:J").Select
　　　　Selection.ClearContents
　　　　Range("A1").Select
　　　　If ActiveSheet.Shapes.Count <> 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Cut '切り取り
　　　　　　Sheets("仮シート").Select
　　　　　　Range("Q1").Select
　　　　　　ActiveSheet.Paste
　　　　　　Application.CutCopyMode = False
　　　　End If
　　　　On Error GoTo 0
　　　　
　　　　zkDate = Day(Sheets("アイコン整理").Range("C5").Value) 'スタート日
　　　　zkDate1 = Sheets("仮シート").Range("B1").Value '画像を並べるスタート日付
　　　　Sheets("仮シート").Select
　　　　Range("A1").Select
　　　　zkRows = 1
　　　　zkRows1 = 2
　　　　zkColumn = 1
　　　　Sheets("RT").Range("A1").Value = zkDate
　　　　Do '画像を[RT]に並べる
　　　　
　　　　　　If zkDate1 > Sheets("仮シート").Range("B" & zkRows).Value Then
　　　　　　　　If zkColumn <> 1 Then
　　　　　　　　　　zkRows1 = zkRows1 + 1
　　　　　　　　End If
　　　　　　　　Sheets("RT").Cells(zkRows1, 1).Value = Day(Sheets("仮シート").Range("B" & zkRows).Value)
　　　　　　　　zkRows1 = zkRows1 + 1
　　　　　　　　zkColumn = 1
　　　　　　End If
　　　　　　
　　　　　　If zkDate1 = Sheets("仮シート").Range("B" & zkRows).Value Then
　　　　　　
　　　　　　　　zkAccount = Sheets("仮シート").Range("A" & zkRows).Value
　　　　　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　　　　　　　Sheets("仮シート").Select '★
　　　　　　　　　　Range("A1").Select
　　　　　　　　　　ActiveSheet.Shapes(zkAccount).Select 'ない場合はエラー
　　　　　　　　　　If Err.Number = 0 Then
　　　　　　　　　　　　Selection.Name = zkAccount
　　　　　　　　　　　　Selection.Cut '画像切り取り
　　　　　　　　　　　　Sheets("RT").Select
　　　　　　　　　　　　Cells(zkRows1, zkColumn).Select
　　　　　　　　　　　　ActiveSheet.Paste
　　　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　　　If zkColumn = 10 Then
　　　　　　　　　　　　　　zkColumn = 1
　　　　　　　　　　　　　　zkRows1 = zkRows1 + 1
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　zkColumn = zkColumn + 1
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　On Error GoTo 0
　　　　　　　　
　　　　　　Else
　　　　　　
　　　　　　　　zkDate1 = Sheets("仮シート").Range("B" & zkRows).Value
　　　　　　　　
　　　　　　End If
　　　　　　zkRows = zkRows + 1
　　　　　　
　　　　Loop Until Sheets("仮シート").Range("A" & zkRows).Value = ""
　　　　
　　End If
　　
　　Sheets("RT").Select
　　Range("A1").Select
　　
　　Sheets("仮シート").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　ActiveSheet.DrawingObjects.Select
　　　　Selection.Delete
　　End If

　　Call いいねアイコン整理
　
End Sub
Sub いいねアイコン整理()

　　zkDate = CDate(Sheets("アイコン整理").Range("C5").Value) '基準日付
　　
　　Sheets("仮シート").Select
　　Cells.Font.Size = 11
　　Sheets("仮シート").Select
　　Columns("A:E").Select
　　Selection.ClearContents
　　Range("A1").Select
　　
　　Sheets("クリック確認").Select '基準日付データから「いいね」シートにアイコンを並べる」
　　Range("A1").Select
　　Selection.CurrentRegion.Select
　　zkRowsL = Selection.Rows.Count
　　Range("B2" & ":H" & zkRowsL).Select
　　Selection.Copy
　　Range("A1").Select
　　Sheets("仮シート").Select
　　Range("A1").PasteSpecial Paste:=xlValues
　　Application.CutCopyMode = False
　　Columns("B:C").Select
　　Selection.Delete Shift:=xlToLeft
　　Columns("D").Select
　　Selection.Delete Shift:=xlToLeft
　　
　　Range("A1").Select
　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Clear
　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Add Key:=Range("B1:B" & zkRowsL - 1) _
　　　　, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Add Key:=Range("C1:C" & zkRowsL - 1) _
　　　　, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　ActiveWorkbook.Worksheets("仮シート").Sort.SortFields.Add Key:=Range("D1:D" & zkRowsL - 1) _
　　　　, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　With ActiveWorkbook.Worksheets("仮シート").Sort
　　　　.SetRange Range("A1:D" & zkRowsL - 1)
　　　　.Header = xlGuess
　　　　.MatchCase = False
　　　　.Orientation = xlTopToBottom
　　　　.SortMethod = xlPinYin
　　　　.Apply
　　End With

　　zkRows = 0
　　Set zkFoundCell = Range("B:B").Find(What:=Sheets("仮シート").Range("B1").Value - 1, LookIn:=xlValues) '日付を検索
　　
　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　If zkFoundCell Is Nothing Then '日付検索の有無
　　　　zkRows = Cells(Rows.Count, 3).End(xlUp).Row
　　Else
　　　　zkFoundCell.Activate
　　　　zkRows = ActiveCell.Row - 1
　　End If
　　On Error GoTo 0
　　
　　Range("A" & zkRows + 1 & ":D" & zkRowsL).Select
　　Selection.ClearContents
　　Range("A1").Select
　　
　　If zkRows > 0 Then '日付検索の有り場合実行
　　　　
　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　Sheets("当日いいね").Select '画像を[仮シート]に移す
　　　　Columns("A:J").Select
　　　　Selection.ClearContents
　　　　Range("A1").Select
　　　　If ActiveSheet.Shapes.Count <> 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Cut '切り取り
　　　　　　Sheets("仮シート").Select
　　　　　　Range("G1").Select
　　　　　　ActiveSheet.Paste
　　　　　　Application.CutCopyMode = False
　　　　End If
　　　　
　　　　Sheets("前日いいね").Select '画像を[仮シート]に移す
　　　　Columns("A:J").Select
　　　　Selection.ClearContents
　　　　Range("A1").Select
　　　　If ActiveSheet.Shapes.Count <> 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Cut '切り取り
　　　　　　Sheets("仮シート").Select
　　　　　　Range("L1").Select
　　　　　　ActiveSheet.Paste
　　　　　　Application.CutCopyMode = False
　　　　End If
　　　　
　　　　Sheets("いいね").Select '画像を[仮シート]に移す
　　　　Columns("A:J").Select
　　　　Selection.ClearContents
　　　　Range("A1").Select
　　　　If ActiveSheet.Shapes.Count <> 0 Then
　　　　　　ActiveSheet.DrawingObjects.Select
　　　　　　Selection.Cut '切り取り
　　　　　　Sheets("仮シート").Select
　　　　　　Range("Q1").Select
　　　　　　ActiveSheet.Paste
　　　　　　Application.CutCopyMode = False
　　　　End If
　　　　On Error GoTo 0
　　　　
　　　　zkDate = Day(Sheets("アイコン整理").Range("C5").Value) 'スタート日
　　　　Sheets("仮シート").Select
　　　　Range("A1").Select
　　　　zkRows = 1
　　　　zkRows1 = 2
　　　　zkColumn = 1
　　　　Sheets("いいね").Range("A1").Value = zkDate
　　　　
　　　　Do '画像を[いいね]に並べる
　　　　　　
　　　　　　zkAccount = Sheets("仮シート").Range("A" & zkRows).Value
　　　　　　On Error Resume Next 'エラー無視で次のステートメントに進む
　　　　　　　　Sheets("仮シート").Select '★
　　　　　　　　Range("A1").Select
　　　　　　　　ActiveSheet.Shapes(zkAccount).Select 'ない場合はエラー
　　　　　　　　If Err.Number = 0 Then
　　　　　　　　　　Selection.Name = zkAccount
　　　　　　　　　　Selection.Cut '画像切り取り
　　　　　　　　　　Sheets("いいね").Select
　　　　　　　　　　Cells(zkRows1, zkColumn).Select
　　　　　　　　　　ActiveSheet.Paste
　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　If zkColumn = 10 Then
　　　　　　　　　　　　zkColumn = 1
　　　　　　　　　　　　zkRows1 = zkRows1 + 1
　　　　　　　　　　Else
　　　　　　　　　　　　zkColumn = zkColumn + 1
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　On Error GoTo 0
　　　　　　　　
　　　　　　zkRows = zkRows + 1
　　　　　　
　　　　Loop Until Sheets("仮シート").Range("A" & zkRows).Value = ""
　　　　
　　End If
　　
　　Sheets("いいね").Select
　　Range("A1").Select
　　
　　Sheets("仮シート").Select
　　If ActiveSheet.Shapes.Count > 0 Then
　　　　ActiveSheet.DrawingObjects.Select
　　　　Selection.Delete
　　End If
　　Sheets("仮シート").Select
　　Columns("A:E").Select
　　Selection.ClearContents
　　Range("A1").Select
　　
　　Sheets("アイコン整理").Select
　　Range("C5").Select
　　MsgBox "整理まとめ完了⇒日付を変更して下さい。"

　　Application.ScreenUpdating = True '画面更新を許可する
　　ThisWorkbook.Save
End Sub

私はこの様に処理をしました

私はこの様に
処理をしました