FC2ブログ

一括名前指定 変更

2017–08–29 (Tue) 14:18
一括名前指定を変更しました。
式が全体的に短くなりました(ファイルを軽くするため)
Counta を使うのも良いですが、重くなるのであまり増減の無いファイル(マクロを実行するにあたって苦にならないファイル)は、
Range().address 又は Cells().addressで指定してしまう方が良いかもしれません。

name Change


Sub 一括名前指定()

Application.Calculation = xlCalculationManual
Dim awb As Workbook
Set awb = ActiveWorkbook
Dim Awbn As Names
Set Awbn = awb.Names
On Error Resume Next

syoz = WorksheetFunction.CountA(Worksheets("住所データ").Range("b:b"))
With Awbn
.Add Name:="その他データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""その他データ""&""!$c$2""),,,COUNTA(INDIRECT(""その他データ""&""!$c:$c"")),12)"
.Add Name:="一般健診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""一般健康診断個人票""&""!$c$2""),,,COUNTA(INDIRECT(""一般健康診断個人票""&""!$c:$c"")),10)"
.Add Name:="会社データ", RefersToR1C1:= _
"=OFFSET(INDIRECT(""会社データ""&""!$B$2""),,,COUNTA(INDIRECT(""会社データ""&""!$B:$B"")),19)"
.Add Name:="再下請負", RefersToR1C1:= _
"=OFFSET(INDIRECT(""textデータ出力""&""!$A$2""),,,COUNTA(INDIRECT(""textデータ出力""&""!$B:$B"")),20)"
.Add Name:="資格", RefersToR1C1:= _
"=OFFSET(INDIRECT(""資格証全て!""&""$B$2""),,,COUNTA(資格証全て!C1),6)"
.Add Name:="住所データ", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Cells(syoz, 26).Address
.Add Name:="資格取得", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Cells(syoz, 26).Address


.Add Name:="フリガナ", RefersTo:="=" & "住所データ!" & Range("f2").Address & ":" & Range("f" & syoz).Address
.Add Name:="郵便番号", RefersTo:="=" & "住所データ!" & Range("g2").Address & ":" & Range("g" & syoz).Address
.Add Name:="住所", RefersTo:="=" & "住所データ!" & Range("h2").Address & ":" & Range("h" & syoz).Address
.Add Name:="電話番号", RefersTo:="=" & "住所データ!" & Range("i2").Address & ":" & Range("i" & syoz).Address
.Add Name:="緊急連絡先住所", RefersTo:="=" & "住所データ!" & Range("j2").Address & ":" & Range("j" & syoz).Address
.Add Name:="緊急連絡先氏名", RefersTo:="=" & "住所データ!" & Range("k2").Address & ":" & Range("k" & syoz).Address
.Add Name:="緊急連絡先続柄", RefersTo:="=" & "住所データ!" & Range("l2").Address & ":" & Range("l" & syoz).Address
.Add Name:="緊急連絡先電話", RefersTo:="=" & "住所データ!" & Range("m2").Address & ":" & Range("m" & syoz).Address
.Add Name:="職種", RefersTo:="=" & "住所データ!" & Range("n2").Address & ":" & Range("n" & syoz).Address
.Add Name:="入社年月日", RefersTo:="=" & "住所データ!" & Range("o2").Address & ":" & Range("o" & syoz).Address
.Add Name:="経験年数", RefersTo:="=" & "住所データ!" & Range("p2").Address & ":" & Range("p" & syoz).Address
.Add Name:="生年月日", RefersTo:="=" & "住所データ!" & Range("q2").Address & ":" & Range("q" & syoz).Address
.Add Name:="年齢", RefersTo:="=" & "住所データ!" & Range("r2").Address & ":" & Range("r" & syoz).Address
.Add Name:="血液型", RefersTo:="=" & "住所データ!" & Range("s2").Address & ":" & Range("s" & syoz).Address
.Add Name:="雇入時教育", RefersTo:="=" & "住所データ!" & Range("t2").Address & ":" & Range("t" & syoz).Address
.Add Name:="所属会社", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("b" & syoz).Address
.Add Name:="氏名", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Range("c" & syoz).Address
.Add Name:="所属会社と氏名", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("c" & syoz).Address
.Add Name:="職歴", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")),5)"
.Add Name:="職歴氏名", RefersToR1C1:= _
"=OFFSET(INDIRECT(""職歴全て""&""!$B$2""),,,COUNTA(INDIRECT(""職歴全て""&""!$B:$B"")))"

a = WorksheetFunction.CountA(Worksheets("社会保険データ").Range("c:c")) + 1
.Add Name:="社会保険", RefersTo:="=" & "社会保険データ!" & Range("c2").Address & ":" & Cells(a, 20).Address
.Add Name:="健康保険種類", RefersTo:="=" & "社会保険データ!" & Range("g2").Address & ":" & Range("g" & a).Address
.Add Name:="健康保険番号", RefersTo:="=" & "社会保険データ!" & Range("h2").Address & ":" & Range("h" & a).Address
.Add Name:="年金種類", RefersTo:="=" & "社会保険データ!" & Range("i2").Address & ":" & Range("i" & a).Address
.Add Name:="年金番号", RefersTo:="=" & "社会保険データ!" & Range("j2").Address & ":" & Range("j" & a).Address
.Add Name:="雇用保険番号", RefersTo:="=" & "社会保険データ!" & Range("k2").Address & ":" & Range("k" & a).Address
.Add Name:="労働契約書", RefersTo:="=" & "社会保険データ!" & Range("l2").Address & ":" & Range("l" & a).Address

.Add Name:="社保取得日", RefersTo:="=" & "社会保険データ!" & Range("m2").Address & ":" & Range("m" & a).Address



.Add Name:="所属会社", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("b" & syoz).Address
.Add Name:="氏名", RefersTo:="=" & "住所データ!" & Range("c2").Address & ":" & Range("c" & syoz).Address
.Add Name:="所属会社と氏名", RefersTo:="=" & "住所データ!" & Range("b2").Address & ":" & Range("c" & syoz).Address



.Add Name:="協力会社社員経験チェックシート", RefersToR1C1:= _
"=OFFSET(INDIRECT(""協力会社社員経験チェックシート""&""!$B$6""),,,COUNTA(INDIRECT(""協力会社社員経験チェックシート""&""!$B:$B""))+10,35)"

.Add Name:="運転免許証", RefersToR1C1:= _
"=OFFSET(INDIRECT(""運転免許証""&""!C2""),,,COUNTA(INDIRECT(""運転免許証""&""!$C:$C"")),7)"

.Add Name:="電離検診", RefersToR1C1:= _
"=OFFSET(INDIRECT(""電離検診""&""!$c$2""),,,COUNTA(INDIRECT(""電離検診""&""!$c:$c"")),4)"


End With
Dim Wss As Worksheet
Set Wss = Worksheets("資格証全て")
Dim Wjs As Worksheet
Set Wjs = Worksheets("住所データ")
Dim nyuryokukazu As Integer
nyuryokukazu = 0
For i = 2 To 31
If Wjs.Cells(i, 3) <> "" Then nyuryokukazu = nyuryokukazu + 1
Next

Dim Wjscell As Variant
ReDim Wjscell(nyuryokukazu)

Dim hukazu As Variant
hukazu = Range(Wjs.Range("c2"), Wjs.Cells(nyuryokukazu + 1, 3))
For i = 1 To nyuryokukazu
If nyuryokukazu = 1 Then
Wjscell(i - 1) = hukazu
Else
Wjscell(i - 1) = hukazu(i, 1)
End If
Next

For i = nyuryokukazu + 1 To 30
ken = StrConv(i, vbWide)
For Each nm In awb.Names
If InStr(nm.Name, ken) <> 0 Then
nm.Delete
End If
Next nm
Next

Dim Wsshoku As Worksheet
Set Wsshoku = Worksheets("職歴全て")
With Wsshoku.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
End With
Dim syokureki As Variant
syokureki = Range(Wsshoku.Range("b1"), Wsshoku.Cells(MaxRow, 2))

With Wss.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With

Dim skn As Variant
skn = Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2))
Dim sss As Variant
sss = Range(Wss.Range("c1"), Wss.Cells(MaxRow, 3))





Dim sk As String
sk = "資格証全て!"

For i = 2 To UBound(Wjscell) + 2
On Error Resume Next
If Wjscell(i - 2) <> "" Then
Dim t As Long
t = WorksheetFunction.Match(Wjscell(i - 2), skn, 0)

Dim j As Long

j = WorksheetFunction.CountIf(Range(Wss.Range("b1"), Wss.Cells(MaxRow, 2)), Wjscell(i - 2)) + t - 1

Dim kazu As Long
Dim tatara As String
tatara = StrConv(i - 1, vbWide)
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b" & j), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c" & j), Wss.Cells(MaxRow, 3)), "免")

With Awbn
If kazu <> 0 Then
Dim kosuu As Long
kosuu = kazu
kazu = t + kazu - 1
.Add Name:="免許" & tatara, RefersTo:="=" & sk & Range("D" & j).Address & ":" & Range("G" & kazu).Address
.Add Name:="免許名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="免許番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="免許取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="免許取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
Else
For Each nm In awb.Names
If InStr(nm.Name, "免許") <> 0 And InStr(nm.Name, tatara) <> 0 Then
nm.Delete
End If
Next

End If
kazu = 0

On Error Resume Next
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b" & j), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c" & j), Wss.Cells(MaxRow, 3)), "資")

If kazu <> 0 Then
kosuu = kazu
kazu = t + kazu - 1

.Add Name:="資格" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="資格名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="資格番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="資格取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="資格取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
t = t + kosuu
Else
For Each nm In awb.Names
If InStr(nm.Name, "資格") <> 0 And InStr(nm.Name, tatara) <> 0 Then
nm.Delete
End If
Next
End If

kazu = 0
On Error Resume Next
kazu = WorksheetFunction.CountIfs(Range(Wss.Range("b" & j), Wss.Cells(MaxRow, 2)), Wjscell(i - 2), Range(Wss.Range("c" & j), Wss.Cells(MaxRow, 3)), "特")

If kazu <> 0 Then
kazu = kazu + t - 1
.Add Name:="特別教育" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("G" & kazu).Address
.Add Name:="特別教育名前" & tatara, RefersTo:="=" & sk & Range("D" & t).Address & ":" & Range("D" & kazu).Address
.Add Name:="特別教育番号" & tatara, RefersTo:="=" & sk & Range("e" & t).Address & ":" & Range("e" & kazu).Address
.Add Name:="特別教育取得日" & tatara, RefersTo:="=" & sk & Range("f" & t).Address & ":" & Range("f" & kazu).Address
.Add Name:="特別教育取得先" & tatara, RefersTo:="=" & sk & Range("g" & t).Address & ":" & Range("g" & kazu).Address
Else
For Each nm In awb.Names
If InStr(nm.Name, "特別教育") <> 0 And InStr(nm.Name, tatara) <> 0 Then
nm.Delete
End If
Next
End If

End With


sksk = WorksheetFunction.Match(Wjscell(i - 2), syokureki, 0)
kazu = WorksheetFunction.CountIf(Range(Wsshoku.Range("b" & sksk), Wsshoku.Cells(MaxRow, 2)), Wjscell(i - 2)) - 1 + WorksheetFunction.Match(Wjscell(i - 2), syokureki, 0)
If kazu <> 0 Then
tatara = StrConv(i - 1, vbWide)
kazu = kazu
With Awbn
.Add Name:="職歴" & tatara, RefersTo:="=" & "職歴全て!" & Range("C" & sksk).Address & ":" & Range("F" & kazu).Address
.Add Name:="職歴自" & tatara, RefersTo:="=" & "職歴全て!" & Range("C" & sksk).Address & ":" & Range("C" & kazu).Address
.Add Name:="職歴至" & tatara, RefersTo:="=" & "職歴全て!" & Range("d" & sksk).Address & ":" & Range("d" & kazu).Address
.Add Name:="職歴客先名" & tatara, RefersTo:="=" & "職歴全て!" & Range("e" & sksk).Address & ":" & Range("e" & kazu).Address
.Add Name:="職歴件名" & tatara, RefersTo:="=" & "職歴全て!" & Range("F" & sksk).Address & ":" & Range("F" & kazu).Address

End With
End If

End If


Next
Application.Calculation = xlCalculationAutomatic
End Sub
スポンサーサイト



« CSVかエクセルか | HOME |  データ更新(追記有) CSVファイルにに書き込む »

コメント

コメントの投稿

 
管理者にだけ表示

 | HOME | 

プロフィール

はる

Author:はる
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク