2026-09-07

大量のExcelデータを立ち上げないで処理をする

Dim Ws As Worksheet
Dim Ds As Worksheet
Dim Gyo2 As Long

Dim Mydata As Variant
Dim Mydata1 As Variant
Dim Mydata2 As Variant
Dim Mydata3 As Variant
Dim MyArray() As Variant
Dim MyRow() As Long
Dim Item As Long
Dim Idx As Long

Set Ws = Wb.Sheets("A")

'集計表は１単位４行構成で作成した表でデータファイルも特殊な構成だが

'ファイルを立ち上げることなく高速で処理をしたいが目的

'この作業では約700ファイルのデータを処理している

Dim AA As Long

Gyo2 = Ws.Cells(Rows.Count, 3).End(xlUp).Row

Item = (Gyo2 - 4) / 4
ReDim MyArray(Item)
ReDim MyRow(Item)
Idx = 0
For AA = 5 To Gyo2 Step 4
Idx = Idx + 1
Mydata1 = Ws.Cells(AA, 3).Value
Mydata2 = Ws.Cells(AA, 5).Value
Mydata3 = Ws.Cells(AA, 6).Value


Mydata = Mydata1 & "-" & Val(Mydata2) & "-" & Val(Mydata3) 'セルを配列に格納
MyRow(Idx) = AA
MyArray(Idx) = Mydata

Next AA

Set Ds = Wb.Sheets("Data")

FNAME = DRC & GNAME
DNAME = Dir(FNAME & "\*.xlsx")

Shname = "収容表"

Do While DNAME <> ""

'集計表に格納用シート（Data）を設けブック間の計算式を作成

Ds.Range("A1:BN90").FormulaR1C1 = "='" & FNAME & "\[" & DNAME & "]" & Shname & "'!RC"

Ds.Range("A1:BN90").Value = Ds.Range("A1:BN90").Value

Application.Calculation = xlCalculationManual
YourArray = Ds.Cells(2, 2) & "-" & Val(Ds.Cells(5, 5)) & "-" & Val(Ds.Cells(6, 8))

For EE = 1 To Idx

If MyArray(EE) = YourArray Then
SyukeiRow = MyRow(EE)

For BB = 15 To 75 Step 20
JB = (BB - 15) / 20 '集計表の入力行を決定
'本来空白でないが空白かの処理
If Ds.Cells(BB, 2) <> "0" Then
For CC = 4 To 66
Set Rng = Ds.Range(Ds.Cells(BB, CC), Ds.Cells(BB + 15, CC))
'計算式では空白部分が「０」となるが有効な０表示が消去されないように

'処理が必要なところのみを消去する

　　　　 Rng.Replace What:="0", Replacement:=""
'今回は対象区間でひとつでも空白でないセルがあるかないか

n = WorksheetFunction.CountA(Rng)
If n > 0 Then
Ws.Cells(SyukeiRow + JB, CC + 9) = "●"
End If
Next CC
Else
Ws.Cells(SyukeiRow + JB, 11).Interior.Color = 12632256
Ws.Cells(SyukeiRow + JB, 12) = ""
End If

Next BB
End If
Next EE
Application.Calculation = xlCalculationAutomatic
Ds.Cells.ClearContents

'****************************************************************************
'ビル単位の情報を該当する装置を作成した配列と比較しデータを入力
'****************************************************************************

DNAME = Dir()
Loop

2026-09-07

CSVを読み取るVBA　（思惑通り読み取れないデータの対処）

各CSVのデータを1行ずつ読み取る予定で作成したVBA

Set Wb = Workbooks(WBNAME)
Set Ws = Wb.Sheets("A")
Set Data_Sh = Wb.Sheets("B")
Gyo2 = Ws.Cells(Rows.Count, 3).End(xlUp).Row
Data_Sh.Visible = True

Application.ScreenUpdating = False

'I取得したCSVファイルを検索
FNAME = DRC & GNAME
DNAME = Dir(FNAME & "\*.csv")

Do While DNAME <> ""
' ファイルを開く（表示せずに読み込み）
Open FNAME & "\" & DNAME For Input As #1
Dim QQ As Integer
QQ = 1
Dim C_data As Variant

Do Until EOF(1)
Line Input #1, lineData ' 1行読み込み
C_data = Split(lineData, ",") ' カンマ区切りで配列化
' 読み込んだデータをシートに書き込み
Dim i As Long
For i = LBound(C_data) To UBound(C_data)
Data_Sh.Cells(QQ, i + 1).Value = C_data(i)
Next i
QQ = QQ + 1
Loop

Close #1
'***********************************************************************************
'当該CSVファイルの改行を認識せず１ラインで読み込んでしまうため
'以下で改行処理をし出力イメージになるようにした
'今回のCSVファイルは６行構成固定データ、不定の場合はA列が空白か

　'否かをFor ～Nextで作成するかな？
　 Data_Sh.Range("A2:Z2").Value = Data_Sh.Range("AJ1:BI1").Value
Data_Sh.Range("A3:Z3").Value = Data_Sh.Range("BR1:CQ1").Value
Data_Sh.Range("A4:Z4").Value = Data_Sh.Range("CZ1:DY1").Value
Data_Sh.Range("A5:Z5").Value = Data_Sh.Range("EH1:FG1").Value
Data_Sh.Range("A6:Z6").Value = Data_Sh.Range("FP1:GO1").Value
'***********************************************************************************

'集計シートへ書き込む処理
Call 状況確認

Data_Sh.Cells.ClearContents

DNAME = Dir()
Loop

2026-08-09

VBA 連想配列で複数の情報を得たい場合

Sub 連想配列で複数の情報を得たい場合()

'************事前準備***************************
'参照設定：Microsoft Scripting Runtime
'***********************************************
'Dim YourDic As Dictionary
'Set YourDic = New Dictionary
'***********************************************
'参照設定を設定しない場合
'Dim YourDic As Object
'Set YourDic = CreateObject("Scripting.Dictionary")
'***********************************************

Dim Cro_Sht As Worksheet
Dim Zu_Sht As Worksheet

Set Cro_Sht = Sheets("Sheet1")
Set Zu_Sht = Sheets("Sheet2")

If Cro_Sht.FilterMode = True Then
Cro_Sht.ShowAllData
End If

If Zu_Sht.FilterMode = True Then
Zu_Sht.ShowAllData
End If

Dim XX As Long
Dim YY As Long

XX = Cro_Sht.Cells(Rows.Count, 2).End(xlUp).Row
YY = Zu_Sht.Cells(Rows.Count, 2).End(xlUp).Row

Cro_Sht.Range("E11:G" & XX).ClearContents
'***********************************************
'各支店からの報告データを連想配列にする
'※　支店によりkeyになる項目表現が違う場合
'※　総設備数、使用設備数　複数のitemを把握したい場合
'***********************************************
Dim YourZu As Variant
Dim YourData As Variant
Dim YourUsed As Variant

Dim YourDic1 As Object
Dim YourDic2 As Object
Set YourDic1 = CreateObject("Scripting.Dictionary")

Dim CC As Long

For CC = 4 To YY

Zu_Sht.Cells(CC, 65).Value = ""

If InStr(Zu_Sht.Cells(CC, 24).Value, "東京") > 0 Then '東京の場合

YourZu = Zu_Sht.Cells(CC, 2).Value & "-" & _
Zu_Sht.Cells(CC, 25).Value

YourData = Val(Zu_Sht.Cells(CC, 29).Value)
YourUsed = Val(Zu_Sht.Cells(CC, 30).Value)

If Not YourDic1.Exists(YourZu) Then
Set YourDic2 = CreateObject("Scripting.Dictionary")

YourDic2.Add "setsubi", YourData
YourDic2.Add "used", YourUsed
YourDic1.Add YourZu, YourDic2
Else
Set YourDic2 = YourDic1(YourZu)
YourDic2("setsubi") = YourDic2("setsubi") + YourData
YourDic2("used") = YourDic2("used") + YourUsed
End If

ElseIf InStr(Zu_Sht.Cells(CC, 24).Value, "大阪") > 0 Then '大阪の場合

YourZu = Zu_Sht.Cells(CC, 2).Value & "-" & _
Right(Zu_Sht.Cells(CC, 25).Value, 3)

End If
Next CC
'***********************************************
'報告データデータを管理表にまとめる
'***********************************************
Dim Key As Variant
Dim QQ As Long
QQ = 11
For Each Key In YourDic1.keys
Set YourDic2 = YourDic1(Key)
Cro_Sht.Cells(QQ, 5).Value = YourDic2("setsubi")
Cro_Sht.Cells(QQ, 6).Value = YourDic2("used")

QQ = QQ + 1
Next

End Sub

2026-08-03

配列　連想配列を使って複数個所にデータ入力

Sub 集計案動作確認済()
'***********************************************
'データシートにある装置を格納
'***********************************************
Dim XX As Long
Dim YY As Long
Dim AA As Long
Dim Elem As Long
Dim YourDs As Worksheet
Dim Yourabc As Variant
Dim Yourdata As Variant
Set YourDs = Workbooks(SNAME).Sheets("データ")
Dim k As Long
YY = YourDs.Cells(Rows.Count, 2).End(xlUp).Row
Application.Calculation = xlCalculationManual

'***********************************************
'データシートにある現装置の配列を連想配列にする
'***********************************************
Dim YourDic As Object
Set YourDic = CreateObject("Scripting.Dictionary")
For AA = 2 To YY
If YourDs.Cells(AA, 16) <> "" And YourDs.Cells(AA, 30) = "良" And YourDs.Cells(AA, 58) = "0" Or YourDs.Cells(AA, 58) = "4" Then

Yourabc = YourDs.Cells(AA, 2).Value & "-" & Val(YourDs.Cells(AA, 16).Value) & "-" & Val(YourDs.Cells(AA, 17).Value) & "-" & Val(YourDs.Cells(AA, 18).Value) & "-" & Val(YourDs.Cells(AA, 19).Value) '架・ユニット・スロット・ポート
Yourdata = YourDs.Cells(AA, 7).Value & "-" & YourDs.Cells(AA, 8).Value & "-" & YourDs.Cells(AA, 9).Value 'OLT架・OLTユニット・OLTスロット・OLTポート

If Not YourDic.Exists(Yourabc) Then
YourDic.Add Yourabc, Yourdata
End If

End If
Next AA
'***********************************************
'集計シートに該当のデータを転記
'***********************************************
Dim MyWs As Worksheet
Dim Myabc As Variant
Dim BB As Integer
Dim CC As Integer
Set MyWs = Workbooks(WBNAME).Sheets("集計表")
XX = MyWs.Cells(Rows.Count, 2).End(xlUp).Row

'Dim Arr(3) As Variant
For AA = 4 To XX
For BB = 3 To 16
Myabc = MyWs.Cells(AA, 2).Value & "-" & Val(MyWs.Cells(AA, 3).Value) & "-" & Val(MyWs.Cells(AA, 4).Value) & "-" & Val(MyWs.Cells(AA, 5).Value) & "-" & BB

If YourDic.Exists(Myabc) Then

If MyWs.Cells(AA, 27) = "G" Then
CC = BB - 2
Else
If BB < 10 Then
CC = BB - 4
Else
CC = BB - 8
End If
End If
MyWs.Cells(AA, 5 + CC) = "●"
MyWs.Cells(AA, 42 + CC) = YourDic(Myabc)
End If
Next BB
Next AA

Application.Calculation = xlCalculationAutomatic
End Sub

2026-07-25

配列　リストの追加漏れを探す

Sub 不足リスト作成()

'***********************************************
'管理表シートにないabcd装置を追加作成
'***********************************************
Dim Ws As Worksheet
Dim Myabcd() As Variant
Set Ws = Sheets("2026")
Dim XX As Long
XX = Ws.Cells(Rows.Count, 7).End(xlUp).Row
'***********************************************
'管理表シートにある現abcdの配列
'***********************************************
ReDim Myabcd((XX - 3) / 2)
For i = 4 To XX Step 2
Myabcd(i / 2 - 1) = Ws.Cells(i, 7).Value & "-" & Ws.Cells(i, 11).Value 'セルを配列に格納
Next i
'***********************************************
'管理表シートにある現abcdの配列を連想配列にする
'***********************************************
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
Dim AA As Long
For AA = LBound(Myabcd) To UBound(Myabcd)
myDic.Add Myabcd(AA), 1
Next AA
'***********************************************
'管理表シートに未登録装置を抽出すする
'***********************************************
Dim YY As Long
Dim arr() As String
Dim msg As String
Dim Yourabcd As Variant
Dim Ds As Worksheet 'abcdシートの全abcdリストから登録漏れを抽出
Set Ds = Sheets("japan")
YY = Ds.Cells(Rows.Count, 1).End(xlUp).Row
For AA = 2 To YY
msg = "追加装置はありません"
If Left(Ds.Cells(AA, 12), 4) = "abcd" Then
Yourabcd = Ds.Cells(AA, 2).Value & "-" & Ds.Cells(AA, 12).Value
If Not myDic.Exists(Yourabcd) Then
msg = "追加装置があります"
arr = Split(Yourabcd, "-")
Ws.Cells(XX + 1, 7) = arr(0)
Ws.Cells(XX + 2, 7) = arr(0)
Ws.Cells(XX + 1, 11) = arr(1)
Ws.Cells(XX + 2, 11) = arr(1)
Ws.Cells(XX + 1, 12) = 1
Ws.Cells(XX + 2, 12) = 2
XX = XX + 2
End If
End If
Next AA

MsgBox msg

End Sub

2026-07-25

配列　データ転記

Sub 管理表更新()
'***************************************
'集計シート、データシートの設定
'***************************************
Dim XX As Long, YY As Long
Set Mydata = Sheets("2026")
Set Yourdata = Sheets("japan")

XX = Mydata.Cells(Rows.Count, 1).End(xlUp).Row
YY = Yourdata.Cells(Rows.Count, 3).End(xlUp).Row
'***************************************
'データシート全体を連想配列Dictionaryを使って処理
'***************************************
Dim Yourdic As Object
Set Yourdic = CreateObject("Scripting.Dictionary")

Dim Dickey As String
Dim Dicitem As Long
Dim AA As Long, BB As Long
Dim Yoursmgp As String
Dim Num As Integer
For BB = 2 To YY
If Ds.Cells(BB, 22) <> 2 And Ds.Cells(BB, 22) <> 3 And _
InStr(Ds.Cells(CC, 7), "smgp") > 0 Then
Yoursmgp = StrConv(Mid(Ds.Cells(BB, 7), 11, 8), 1)
Num = Int((Ds.Cells(BB, 8) - 1) / 8) + 1

Dickey = Myedge.Cells(BB, 25).Value & "-" & Yoursmgp & "-" & Num
Dicitem = Myedge.Cells(BB, 16).Value
If Dicedge.Exists(Dickey) Then
Dicedge(Dickey) = Dicedge(Dickey) + Dicitem
Else
Dicedge.Add Dickey, Dicitem
End If
Next BB

'***************************************
'集計シートに結果を転記
'***************************************
Dim Targetkey As String
For AA = 11 To XX
Targetkey = Mydata.Cells(AA, 7).Value & "-" & Val(Mydata.Cells(AA, 10).Value) & "-" & Val(Mydata.Cells(AA, 11).Value)
If Dicedge.Exists(Targetkey) Then
Mydata.Cells(AA, 17) = Dicedge(Targetkey)
Else
Mydata.Cells(AA, 17) = ""
End If
Next AA

End Sub

2026-07-20

配列（基礎実践）連想配列でSUMIF

Sub 連想配列SUMIF()
'************事前準備*******************
'参照設定：Microsoft Scripting Runtime
'***************************************

'***************************************
'集計シート、データシートの設定
'***************************************
Dim XX As Long, YY As Long
Set Smg = Sheets("Sheet2")
Set Myedge = Sheets("Sheet1")

XX = Smg.Cells(Rows.Count, 1).End(xlUp).Row
YY = Myedge.Cells(Rows.Count, 1).End(xlUp).Row
'***************************************
'データシート全体を連想配列Dictionaryを使って処理
'***************************************

'参照設定：Microsoft Scripting Runtime を設定しない場合は右コメントに変更
Dim Dicedge As Dictionary 'Dim Dicedge As Object
Set Dicedge = New Dictionary 'Set Dicedge = CreateObject("Scripting.Dictionary")

Dim Edgekey As String
Dim Edgesuu As Long
Dim AA As Long, BB As Long

For BB = 2 To YY
Edgekey = Myedge.Cells(BB, 1)
Edgesuu = Myedge.Cells(BB, 4)
If Dicedge.Exists(Edgekey) Then
Dicedge(Edgekey) = Dicedge(Edgekey) + Edgesuu
Else
Dicedge.Add Edgekey, Edgesuu
End If
Next BB

'***************************************
'集計シートに結果を転記
'***************************************
Dim Targetkey As String
For AA = 11 To XX
Targetkey = Smg.Cells(AA, 1).Value
If Dicedge.Exists(Targetkey) Then
Smg.Cells(AA, 8) = Dicedge(Targetkey)
Else
Smg.Cells(AA, 8) = ""
End If
Next AA

End Sub