★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
★セットもの★
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Public Function shapeExists(sName) '--- シェープ存在確認
Dim objShp As Shape
On Error GoTo NO_OBJECT
If IsObject(wks_main.Shapes(sName)) Then
shapeExists = True
End If
Exit Function
NO_OBJECT:
shapeExists = False
Err.Clear
End Function
Public Sub ReplaceShapeText(sp As Shape, searchText, replaceText)
On Error Resume Next
Dim sp2 As Shape
Dim t As String
If sp.Type = msoGroup Then
For Each sp2 In sp.GroupItems
ReplaceShapeText sp2, searchText, replaceText
Next
Else
t = sp.TextFrame.Characters.Text
'矢印などテキスト設定できないシェイプの場合はエラーになる
If Err Then
Call Err.Clear
Else
sp.TextFrame.Characters.Text = Replace(t, searchText, replaceText)
End If
End If
End Sub
Public Sub ReplaceAllShapeText(searchText, replaceText)
Dim sh As Worksheet
Dim sp As Shape
Set sh = Application.ActiveSheet
For Each sp In sh.Shapes
ReplaceShapeText sp, searchText, replaceText
Next
Set sh = Nothing
End Sub
'*****
' ファイルの文字コードをSJISからUTF8(BOM無し)に変換する
Private Sub convertCharCode_SJIS_to_utf8(infile As String, outfile As String)
Dim destWithBOM As Object: Set destWithBOM = CreateObject("ADODB.Stream")
With destWithBOM
.Type = 2
.Charset = "utf-8"
.LineSeparator = 10 'LF
.Open
' ファイルをSJIS で開いて、dest へ 出力
With CreateObject("ADODB.Stream")
.Type = 2
.Charset = "shift-jis"
.Open
.LoadFromFile infile
.Position = 0
Do While Not .EOS
destWithBOM.WriteText .ReadText(-2), 1
Loop
.Close
End With
' BOM消去
' 3バイト無視してからバイナリとして出力
.Position = 0
.Type = 1 ' adTypeBinary
.Position = 3
Dim dest: Set dest = CreateObject("ADODB.Stream")
With dest
.Type = 1 ' adTypeBinary
.Open
destWithBOM.copyTo dest
.savetofile outfile, 2
.Close
End With
.Close
End With
End Sub
Public Sub codeChange(Filename, changeFile)
Dim FirstObj As Object
Dim SecondObj As Object
Set FirstObj = CreateObject("ADODB.Stream")
With FirstObj
.Type = 2
.Charset = "UTF-8"
.Open
.LoadFromFile Filename
.Position = 0
End With
Set SecondObj = CreateObject("ADODB.Stream")
With SecondObj
.Type = 2
.Charset = "shift-jis"
.Open
End With
FirstObj.copyto SecondObj
SecondObj.Position = 0
NewFilename = changeFile
SecondObj.savetofile NewFilename, 2
End Sub
Function SumColor(計算範囲, 条件色セル)
'--- 初期化
SumColor = 0
SumColorIndex = 条件色セル.Interior.ColorIndex
For x = 1 To 計算範囲.Count
If 計算範囲(x).Interior.ColorIndex = SumColorIndex Then
SumColor = SumColor + 計算範囲(x)
End If
Next
End Function
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
★FileSystemObject関連★
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
●
'--- 宣言
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = Nothing
'--- ファイル確認してから削除
If FSO.FileExists(createName) Then
FSO.DeleteFile createName
End If
If FSO.FileExists(Target) = True Then: FSO.DeleteFile oFile
'--- 新規ファイル作成
With FSO.CreateTextFile(createName)
.WriteLine "aaa"
.Close
End With
'--- 書き込み（追記）
With FSO.GetFile(oFile).OpenAsTextStream(8)
.writeLine getJOB(j)
.write trimData '// 改行なし
.Close
End With
'--- 新規ファイル作成
FSO.CreateTextFile FilePath
FSO2.GetFile(FilePath).OpenAsTextStream(8).Write buf(i)
FSO2.GetFile(FilePath).OpenAsTextStream(8).WriteLine buf(i)
'--- 読み込み
Infile = Split(FSO.GetFile(File.Path).OpenAsTextStream.ReadAll, vbCrLf)
For i = 0 To UBound(Infile)
next i
FSO.GetFile(File.Path).OpenAsTextStream.Close
'--- 上書き確認なし（存在する場合はエラー）
FSO.CopyFile dataMae, dataAto
'--- 上書きでファイルコピー
FSO.CopyFile motoName, sakiName, True
'--- このフォルダ内のファイルの探索
For Each objFile In objFSO.GetFolder(Trim(infolderPath)).Files
With objFile
objFile.Path, outfolderPath & "\" & objFile.Name
End With
Next objFile
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
★特殊関連★
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'--- ダブルコーテーションの別の書き方
trimData = Chr(34) & trimData & Chr(34)
'--- application関連
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.StatusBar = False
'--- 数式の計算をロック実行
Application.Calculation = xlCalculationManual
'--- 数式の計算をロック解除
Application.Calculation = xlCalculationAutomatic
'--- ポップアップ抑止
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("sort").Delete
Application.DisplayAlerts = True
'--- enabled
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
★判定関連★
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
If IsNumeric(sRow) = True Then
If IsEmpty(buf(i, 1)) = True Then
If IsDate(buf(i, TY_STR)) Then
If FoundCell Is Nothing Then
If IsObject(wks_main.Shapes(sName)) Then
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
★備忘録関連★
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
ETLの解析系きっついは XMLのやつ。htmlじゃなくて。
印刷君もきついわ
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'★ツールバー作成
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Private Sub Workbook_Open()
'--- ショートカットキー設定
Application.OnKey "{F1}", "gantoPlot"
On Error Resume Next
For i = 1 To Application.CommandBars(39).Controls.Count
If Application.CommandBars(39).Controls(i).Caption = "行追い出し処理" Then
Application.CommandBars(39).Controls("行追い出し処理").Delete
End If
Next i
'--- ツールバー新規作成
Dim MyCellMenu As CommandBarControl
Set MyCellMenu_01 = Application.CommandBars(39).Controls.Add
With MyCellMenu_01
.Caption = "行追い出し処理"
.OnAction = "backUp_Row"
End With
Set MyCellMenu_01 = Application.CommandBars(42).Controls.Add
With MyCellMenu_01
.Caption = "行追い出し処理"
.OnAction = "backUp_Row"
End With
'--- 標準用
For i = 1 To Application.CommandBars(39).Controls.Count
If Application.CommandBars(39).Controls(i).Caption = "行追い出し処理" Then
Application.CommandBars(39).Controls("行追い出し処理").Delete
End If
Next i
'--- 改ページプレビュー用
For i = 1 To Application.CommandBars(42).Controls.Count
If Application.CommandBars(42).Controls(i).Caption = "行追い出し処理" Then
Application.CommandBars(42).Controls("行追い出し処理").Delete
End If
Next i
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'★いろいろ
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'--- オートシェイプいろいろ
sRow = 1
SheetMax = ThisWorkbook.Worksheets.Count
For j = 1 To SheetMax
shapeMax = ThisWorkbook.Worksheets(j).Shapes.Count
For i = 1 To shapeMax
If InStr(ThisWorkbook.Worksheets(j).Shapes.Item(i).Name, "Rectangle") > 0 Then
ThisWorkbook.Worksheets("Shape").Cells(sRow, "A") = ThisWorkbook.Worksheets(j).Name
ThisWorkbook.Worksheets("Shape").Cells(sRow, "B") = ThisWorkbook.Worksheets(j).Shapes.Item(i).TextEffect.Text sRow = sRow + 1
End If
Next i
Next j
'--- 最終行判定
LastPosi = Range(joukyou & "65536").End(xlUp).Row + 1
'--- エクセル関数使う場合
実績工数 = Application.WorksheetFunction.Sum((Range(colS_A & i & ":" & colE_A & i)))
'--- 曜日の編集論理
calBuf(2, i) = Mid$(WeekdayName(Weekday(calBuf(1, i))), 1, 1)
'--- 祝日判定（営業日が０なら祝日とみなす）
workCnt = Application.WorksheetFunction.NetworkDays(calBuf(1, i), calBuf(1, i), holidayRange)
'--- 重み設定
wks_main.Range(col_PlanWeight1(A) & "4") = "=IF(ISERROR(VLOOKUP(" & col_PlanWorkMember(A) & "4" & ",設定!C:D,2,FALSE)),1,VLOOKUP(" & col_PlanWorkMember(A) & "4" & ",設定!C:D,2,FALSE))"
'--- 計画想定日数2（小数点以下四捨五入する）
wks_main.Range(col_PlanAssumpDate2(A) & "4") = "=ROUND(" & col_PlanAssumpDate1(A) & "4" & ",0)"
'--- 計画想定終了日
wks_main.Range(col_PlanAssumpDateE(A) & "4") = "=WORKDAY(" & col_PlanAssumpDateS(A) & "4" & "," & col_PlanAssumpDate2(A) & "4" & ",設定!$A$2:$A$40)"
rData = Application.VLookup(CLng(sDate), ThisWorkbook.Worksheets("作業工数情報（計画）").Range("F:I"), 4, False)
If Application.WorksheetFunction.NetworkDays(sDate, sDate, ThisWorkbook.Worksheets("設定").Range("$A$2:$A$40")) = 1 Then
'---シートクリアー
ThisWorkbook.Worksheets("分析_タスク確認用").rowS("2:1048576").ClearContents
'--- ピボットテーブル更新
ThisWorkbook.Worksheets("タスク状況確認").PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ2").PivotCache.Refresh
'--- グラフ範囲更新
ThisWorkbook.Worksheets("EVM確認").ChartObjects("グラフ 17").Chart.SetSourceData Source:=Range("EVM確認!$A$1:$A$" & i & ",EVM確認!$G$1:$H$" & i)
'--- 列名取得（数字からアルファベットに変換）
colE = Split(wks_main.Cells(1, colS - 1).Address, "$")(1)
colE_A = Split(wks_main.Range(colS_A & rowDate).End(xlToRight).Address, "$")(1)
'--- ショートカットキーと関数紐付
Application.OnKey "{F1}", "gantoPlot"
'--- 対象範囲一括置換
Workbooks(File.Name).Activate
Workbooks(File.Name).Worksheets(sMin).Activate
Range("A1:DP5000").Select '--置き換え対象範囲を選択します
With Selection
.Replace What:="IPOBC", Replacement:="IPOBQ", LookAt:=xlPart
End With
'--- 曜日の編集論理
calBuf(2, i) = Mid$(WeekdayName(Weekday(calBuf(1, i))), 1, 1)
'--- 曜日
ThisWorkbook.Worksheets("分析_担当者別計画確認用").Cells(sRow, "D") = Mid(WeekdayName(Weekday(j)), 1, 1)
'--- 種類
Select Case File.Attributes
Case 0: FileAttributes = "標準ファイル"
Case 1: FileAttributes = "読み取り専用ファイル"
Case 2: FileAttributes = "隠しファイル"
Case 4: FileAttributes = "システムファイル"
Case 8: FileAttributes = "ディスクドライブボリュームラベル"
Case 16: FileAttributes = "フォルダまたはディレクトリ"
Case 32: FileAttributes = "アーカイブファイル"
Case 64: FileAttributes = "リンクまたはショートカット"
Case 128: FileAttributes = "圧縮ファイル"
Case Else: FileAttributes = "不明"
End Select
'--- FSOのやつ
ThisWorkbook.Worksheets(2).Cells(cnt, "A") = File.Path
ThisWorkbook.Worksheets(2).Cells(cnt, "B") = File.Name
ThisWorkbook.Worksheets(2).Cells(cnt, "C") = File.ParentFolder.Name
ThisWorkbook.Worksheets(2).Cells(cnt, "D") = File.ParentFolder.ParentFolder.Name
ThisWorkbook.Worksheets(2).Cells(cnt, "E") = FileAttributes
ThisWorkbook.Worksheets(2).Cells(cnt, "F") = File.Type
'--- ↓ わーくぶっくおーぷん
Workbooks.Open Filename:=File.Path, ReadOnly:=True, UpdateLinks:=0
'--- フリーズ抑止
DoEvents
'--- 印刷範囲変更
Workbooks(Dir(File.Path)).Worksheets(1).PageSetup.PrintArea = Workbooks(Dir(File.Path)).Worksheets(1).Range("A1:AE" & i).Address
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'★ＩＥ関連
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Dim objIE As InternetExplorer
Dim objShell As Object, objWin As Object
Dim objDoc As HTMLDocument
Set objShell = CreateObject("Shell.Application")
For Each objWin In objShell.Windows
If InStr(objWin.LocationURL, "IPOBC701PointGrantCondList.jsp") > 0 Then
Set objIE = objWin
Exit For
End If
Next
For i = 0 To objIE.document.getElementsByTagName("td").Length - 1
If objIE.document.getElementsByTagName("td")(i).Width = "80%" Then
getCodeId = Trim(objIE.document.getElementsByTagName("td")(i).innerHTML)
getCodeName = Trim(objIE.document.getElementsByTagName("td")(i).PreviousSibling.innerHTML)
If objIE.document.getElementsByTagName("input")(i).Type = "checkbox" And _
InStr(objIE.document.getElementsByTagName("input")(i).Name, "shopSelect") > 0 Then
objIE.document.getElementsByName(IE_List(j, 1)).Item.Checked = False
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'★いろいろ
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'***
svnリームー
'************************
'--- 座標の調べ方
G_TOP = wks_main.Cells(rowS+0, InazumaColI).Top
G_BOT = wks_main.Cells(rowS+1, InazumaColI).Top
G_LFT = wks_main.Cells(rowS+1, InazumaColI).left
'--- シェープの横幅
dwidth = wks_main.Shapes(shapeName).Width
'--- シェープの書き方（四角形）
With wks_main.Shapes.AddLine(p1, p2, p3, p4)
.Name = pName
.Line.DashStyle = msoLineSolid
.Line.Weight = 2
End With
'--- シェープの書き方（横線）
With wks_main.Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
.Line.EndArrowheadStyle = msoArrowheadTriangle
With .ConnectorFormat
.BeginConnect wks_main.Shapes("予定線" & Format(i, "000")), 4
.EndConnect wks_main.Shapes("予定線" & Format(setRow, "000")), 1
End With
End With
'--- 予定のシェープ調べ方
shapeMax = wks_main.Shapes.Count
shapeMin = 1
hitF = 0
Do While shapeMin <= shapeMax
shapeName = wks_main.Shapes(shapeMin).Name
If shapeName = "予定線" & Format(setRow, "000") Then
hitF = 1
Exit Do
End If
shapeMin = shapeMin + 1
Loop
'--- エクセル文字の取得方法
tEDate = wks_main.Range(TY_END_A & setRow).Text
tEDate = wks_main.Range(TY_END_A & setRow).value
tEDate = wks_main.Range(TY_END_A & setRow).value2
'--- セルのマージ方法
ThisWorkbook.Worksheets("マージ").Range(tCol & sRow & ":" & tCol & eRow).Merge
'--- 休日判定色塗り
Select Case calBuf(2, i)
Case "土": wks_main.Columns(i + colS - 1).Interior.Color = 16765331
Case "日": wks_main.Columns(i + colS - 1).Interior.Color = 12040191
Case Else
'--- 祝日判定も入れる
For j = 2 To 100
If ThisWorkbook.Worksheets("設定").Cells(j, "A") = "" Then: Exit For
If ThisWorkbook.Worksheets("設定").Cells(j, "A") = calBuf(1, i) Then
wks_main.Columns(i + colS - 1).Interior.Color = 12040191
End If
Next j
End Select
'--- 時間取りたいとき
getNow6S = CDbl(Timer)
'--- ファイルの開き方
Workbooks.Open Filename:=filePath
Workbooks(Dir(filePath)).Close savechanges:=True
'--- フォームの開き方
UserForm1.Show
Unload UserForm2
'--- UNIONして高速化（めちゃはや）
rng.Interior.Color = 12040191
'--- エクセル編集と関数
With wks_main.Range(cl_PlanAssumpDateS(A) & "2")
.Value = "=MIN(" & col_PlanAssumpDateS(A) & "4" & ":" & col_PlanAssumpDateS(A) & LastPosi & ")"
.NumberFormatLocal = "yy/mm/dd"
End With
'-- 集計値関数再設定（一律集計で設定）
With .Cells(sumRow, col_workPlanTime(N))
.Formula = "=SUM(" & func_RowStrtoRowEnd(col_workPlanTime, col_workPlanTime, sumRowSTR, LastPosi) & ")"
.AutoFill Destination:=wks_main.Range(col_workPlanTime(A) & sumRow & ":" & col_CPI(A) & sumRow), Type:=xlFillValues
End With
'--- デバック方法
Debug.Print "0: ALLTime--" & SetTimmer(1, 0) - SetTimmer(0, 0)
'--- ファイルコピー
Name copyMoto As copySaki
