EXCELVBA



カテゴリ:[ PC/ネット/モバイル ]


7件の内、新着の記事から10件ずつ表示します。


[7] vba7

投稿者: vba 投稿日:2017年 9月 8日(金)01時59分37秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module7"
Declare Function BeepAPI Lib "kernel32.dll" Alias "Beep" _
(ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Sub Sound1()
Dim SoundFile As String, rc As Long
Dim MainSheet1
MainSheet1 = "楽々棚卸"
    SoundFile = Worksheets(MainSheet1).Range("L2").Value
    rc = mciSendString("Play " & SoundFile, "", 0, 0)
    Debug.Print rc
End Sub

Sub Sound2()
Dim SoundFile As String, rc As Long
SoundFile = "C:\Windows\Media\Windows Critical Stop.wav"
    If Dir(SoundFile) = "" Then
        MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation
        Exit Sub
    End If
    SoundFile = """" & SoundFile & """"
    rc = mciSendString("Open " & SoundFile, "", 0, 0)
    rc = mciSendString("Play " & SoundFile & " wait", "", 0, 0)
    rc = mciSendString("Close " & SoundFile, "", 0, 0)
End Sub




[6] vba6

投稿者: vba 投稿日:2017年 9月 8日(金)01時59分5秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module6"
Sub IRISRead()
Dim a
Dim b
Dim c
Dim d
Dim j
Dim k
Dim MainSheet1
MainSheet1 = "楽々棚卸"
Application.ScreenUpdating = False
Application.DisplayAlerts = False

a = "*.csv"
b = ThisWorkbook.Path & "\" & a
j = ThisWorkbook.Worksheets(MainSheet1).Cells(Rows.Count, 8).End(xlUp).Row
j = j + 1
Worksheets(MainSheet1).Range("H3", "H" & j).ClearContents

c = Dir(b)
Do While c <> ""
b = ThisWorkbook.Path & "\" & c
Workbooks.Open b
k = Workbooks(c).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(c).Worksheets(1).Range("A2", "A" & k).Copy
ThisWorkbook.Worksheets(MainSheet1).Range("H3").PasteSpecial Paste:=xlPasteValues

a = MainSheet1 & "にて読込済" & ".csv"
b = ThisWorkbook.Path & "\" & a
ActiveWorkbook.SaveAs Filename:=b, FileFormat:=xlCSV
Workbooks(a).Close
b = ThisWorkbook.Path & "\" & c
Kill b
c = Dir()
Loop

ThisWorkbook.Worksheets(MainSheet1).Range("B7").Select

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub




[5] vba5

投稿者: vba 投稿日:2017年 9月 8日(金)01時58分34秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module5"
Sub 一覧のクリア()
Dim j
Dim MainSheet1
MainSheet1 = "楽々棚卸"
Application.ScreenUpdating = False
j = Worksheets(MainSheet1).Cells(Rows.Count, 5).End(xlUp).Row
If j > 13 Then
Worksheets(MainSheet1).Range("E13", "E" & j).ClearContents
Worksheets(MainSheet1).Range("E13", "E" & j).Interior.ColorIndex = 0
Worksheets(MainSheet1).PageSetup.PrintArea = "A1:F32"
End If
Application.ScreenUpdating = True
End Sub



[4] vba4

投稿者: vba 投稿日:2017年 9月 8日(金)01時58分1秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module4"
Sub 在番又は棚番の検索()
Dim a
Dim b
Dim c
Dim zaiban
Dim tanaban
Dim zenkai
Dim zenkaiws
Dim FoundCell As Variant
Dim lngYLine As Long
Dim intXLine As Integer
Dim CSVSheet1
Dim ws As Worksheet, flag As Boolean
MainSheet1 = "楽々棚卸"
a = 1
b = 1
c = 0
zaiban = Worksheets(MainSheet1).Range("B7").Value
tanaban = Worksheets(MainSheet1).Range("D7").Value
zenkai = Worksheets(MainSheet1).Range("M2").Value
zenkaiws = Worksheets(MainSheet1).Range("N2").Value

If zenkaiws <> "" And zenkai <> "" Then
Worksheets(zenkaiws).Range(zenkai).Interior.ColorIndex = 0
End If

If zaiban = "" Then
MsgBox "検索対象を入力してください"
a = 100
b = 100

ElseIf zaiban <> "" And zaiban <> tanaban Then
For Each ws In Worksheets
c = c + 1
        If ws.Name <> MainSheet1 Then
Set FoundCell = Worksheets(ws.Name).Range("A:A").CurrentRegion.Find(What:=zaiban)
If FoundCell Is Nothing Then
a = 1
GoTo nextsheet
Else
b = 100
lngYLine = Worksheets(ws.Name).Cells.Find(What:=zaiban).Row
Worksheets(ws.Name).Range("A" & lngYLine).Interior.Color = RGB(255, 255, 50)
Worksheets(MainSheet1).Range("M2").Value = "A" & lngYLine
Worksheets(MainSheet1).Range("N2").Value = ws.Name
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "在番" & zaiban & "は" & vbLf & _
"左から" & c & "枚目のシート" & vbLf & ws.Name & "の" & vbLf & "セル" & "A" & lngYLine & "にあります"
End If
End If
nextsheet:
    Next ws

ElseIf zaiban = tanaban Then
For Each ws In Worksheets
c = c + 1
    If ws.Name = tanaban Then
b = 100
Worksheets(MainSheet1).Range("N2").Value = ws.Name
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "棚番" & tanaban & "は" & vbLf & _
"左から" & c & "枚目の" & vbLf & "シートです"
GoTo sheetsearchend
End If
    Next ws
sheetsearchend:

End If
If a = 1 And b = 1 And zaiban <> tanaban And Len(zaiban) > 20 Then
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "在番又は棚番を" _
& vbLf & "入力してください"
Worksheets(MainSheet1).Range("B7").Interior.Color = RGB(255, 100, 100)
ElseIf a = 1 And b = 1 And zaiban <> tanaban Then
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "お探しの在番" & vbLf & _
zaiban & vbLf & "は未登録です"
Worksheets(MainSheet1).Range("B7").Interior.Color = RGB(255, 100, 100)
ElseIf a = 1 And b = 1 And zaiban = tanaban Then
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "お探しの棚番" & vbLf & _
zaiban & vbLf & "は未登録です"
Worksheets(MainSheet1).Range("B7").Interior.Color = RGB(255, 100, 100)
End If
End Sub



[3] vba3

投稿者: vba 投稿日:2017年 9月 8日(金)01時57分30秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module3"
Sub 提出用ファイルの作成()
Dim a
Dim b
Dim c
Dim d
Dim h
Dim j
Dim k
Dim MainSheet1
Dim sagyousya
Dim nengetuhi
Dim Path
Dim Name
Dim MyFile As String
Dim MyFileName As String
Dim Title1
Dim Title2
Dim ws As Worksheet, flag As Boolean
MainSheet1 = "楽々棚卸"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DefaultSaveFormat = xlOpenXMLWorkbook
sagyousya = ThisWorkbook.Worksheets(MainSheet1).Range("B15").Value
nengetuhi = ThisWorkbook.Worksheets(MainSheet1).Range("N1").Value
Title1 = ThisWorkbook.Worksheets(MainSheet1).Range("O1")
Title2 = ThisWorkbook.Worksheets(MainSheet1).Range("O2")
Worksheets(MainSheet1).Range("M2").Value = ""
Worksheets(MainSheet1).Range("N2").Value = ""
b = "=COUNTA(A2:A"
c = ")"
Path = ThisWorkbook.Path

Name = sagyousya & nengetuhi & "棚卸"
MyFile = Name & ".xlsx"
MyFileName = Path & "\" & MyFile
If Dir(MyFileName) <> "" Then
Workbooks.Open MyFileName
ThisWorkbook.Worksheets(MainSheet1).Activate
Else
Application.SheetsInNewWorkbook = 1
Workbooks.Add
ActiveWorkbook.Worksheets(1).Name = Name
ActiveWorkbook.Worksheets(Name).Range("A1").Value = Title1
ActiveWorkbook.Worksheets(Name).Range("B1").Value = Title2
MsgBox Name & "ファイルは無かったので作成しました"
ActiveWorkbook.SaveAs Filename:=MyFileName
ThisWorkbook.Worksheets(MainSheet1).Activate
End If

For Each ws In Worksheets
    If ws.Name <> MainSheet1 Then
d = d + 1
j = ThisWorkbook.Worksheets(ws.Name).Cells(Rows.Count, 1).End(xlUp).Row
h = Workbooks(MyFile).Worksheets(Name).Cells(Rows.Count, 1).End(xlUp).Row
h = h + 1
ThisWorkbook.Worksheets(ws.Name).Range("A2", "B" & j).Copy
Workbooks(MyFile).Worksheets(Name).Cells(h, 1).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets(ws.Name).Delete
    End If
Next ws
k = Workbooks(MyFile).Worksheets(Name).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To k
a = Workbooks(MyFile).Worksheets(Name).Cells(i, 1).Value
If WorksheetFunction.CountIf(Workbooks(MyFile).Worksheets(Name).Range("A1:A" & k), a) > 1 Then
Workbooks(MyFile).Worksheets(Name).Rows(i).Delete
End If
Next i
Workbooks(MyFile).Worksheets(Name).Range("C1") = b & k & c
Workbooks(MyFile).Worksheets(Name).Range("C1").NumberFormatLocal = "####" & """台"""
Workbooks(MyFile).Save
Workbooks(MyFile).Close

ThisWorkbook.Worksheets(MainSheet1).Activate
ThisWorkbook.Worksheets(MainSheet1).Range("B7").Select
Call 一覧のクリア

MsgBox Name & "ファイルに" & d & "棚登録し保存が完了しました"
Application.SheetsInNewWorkbook = 3
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisWorkbook.Save
End Sub



[2] vba2

投稿者: vba 投稿日:2017年 9月 8日(金)01時57分1秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module2"
Sub シートへコピー()
Dim a
Dim b
Dim c
Dim d
Dim h
Dim g
Dim i
Dim j
Dim k
Dim NewWorkSheet As Worksheet
Dim Title1
Dim Title2
Dim ws As Worksheet, flag As Boolean
Dim MainSheet1
MainSheet1 = "楽々棚卸"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
b = "=COUNTA(A2:A"
c = ")"
Title1 = Worksheets(MainSheet1).Range("O1")
Title2 = Worksheets(MainSheet1).Range("O2")
Application.DefaultSaveFormat = xlOpenXMLWorkbook
NewSheetName = Worksheets(MainSheet1).Range("D7").Value
j = Worksheets(MainSheet1).Cells(Rows.Count, 5).End(xlUp).Row
For Each ws In Worksheets
    If ws.Name = NewSheetName Then flag = True
Next ws
If flag = True Then
h = Worksheets(NewSheetName).Cells(Rows.Count, 1).End(xlUp).Row
h = h + 1
Worksheets(MainSheet1).Range("E13", "E" & j).Copy
Worksheets(NewSheetName).Cells(h, 1).PasteSpecial Paste:=xlPasteValues
k = Worksheets(NewSheetName).Cells(Rows.Count, 1).End(xlUp).Row
For i = h To k
a = Worksheets(NewSheetName).Cells(i, 1).Value
If WorksheetFunction.CountIf(Worksheets(NewSheetName).Range("A2:A301"), a) > 1 Then
Worksheets(NewSheetName).Rows(i).Delete
d = d + 1
i = i - 1
ElseIf a <> "" Then
Worksheets(NewSheetName).Cells(i, 2).Value = NewSheetName
End If
Next i
d = k - d
Worksheets(NewSheetName).Range("C1") = b & d & c

Else
Worksheets.Add(After:=Worksheets(MainSheet1)).Name = NewSheetName
Worksheets(MainSheet1).Range("E13", "E" & j).Copy
Worksheets(NewSheetName).Range("A2").PasteSpecial Paste:=xlPasteValues
Worksheets(NewSheetName).Range("A1").Value = Title1
Worksheets(NewSheetName).Range("B1").Value = Title2
k = Worksheets(NewSheetName).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To k
Worksheets(NewSheetName).Cells(i, 2).Value = NewSheetName
Next i
Worksheets(NewSheetName).Range("C1") = b & k & c
Worksheets(NewSheetName).Range("C1").NumberFormatLocal = "####" & """台"""

End If
Worksheets(MainSheet1).Activate
Worksheets(MainSheet1).Range("B7").Select
Call 一覧のクリア
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub




[1] vba1

投稿者: vba 投稿日:2017年 9月 8日(金)01時55分21秒 p437242-ipngn3601hiraide.tochigi.ocn.ne.jp  通報   返信・引用

Attribute VB_Name = "Module1"
Sub 在番欄入力値判定()
Dim mukou
Dim zaiban
Dim zaiban2
Dim tyouhuku
Dim sagyousya
Dim a
Dim aa
Dim b
Dim c
Dim i
Dim j
Dim k
Dim tanabanhantei
Dim MainSheet1
Application.ScreenUpdating = False
MainSheet1 = "楽々棚卸"
zaiban = Worksheets(MainSheet1).Range("B7").Value
tanabanhantei = Worksheets(MainSheet1).Range("K1").Value
j = Worksheets(MainSheet1).Cells(Rows.Count, 8).End(xlUp).Row
a = Mid(zaiban, 1, 1)
aa = Mid(zaiban, 2, 1)
b = Mid(zaiban, 3, 1)
c = Mid(zaiban, 4, 1)
d = Mid(zaiban, 5, 7)
b = UCase(b)
c = UCase(c)
tyouhuku = 0
mukou = 0
zaiban2 = a & aa & b & c & d

If tanabanhantei = 100 And zaiban Like "*-*" And Len(zaiban) < 20 Then
mukou = 1
Worksheets(MainSheet1).Range("K1").Value = 1
Worksheets(MainSheet1).Range("B7").Font.Size = 18
Worksheets(MainSheet1).Range("B7").Interior.ColorIndex = 0
Call シートへコピー
ElseIf tanabanhantei = 1 And zaiban Like "*-*" And Len(zaiban) < 20 Then
mukou = 1
Worksheets(MainSheet1).Range("K1").Value = 100
Worksheets(MainSheet1).Range("D7").Value = zaiban
Worksheets(MainSheet1).Range("B7").Font.Size = 18
Worksheets(MainSheet1).Range("B7").Interior.ColorIndex = 0

ElseIf WorksheetFunction.CountIf(Worksheets(MainSheet1).Range("H3", "H" & j), zaiban2) = 1 Then
mukou = 1
k = Worksheets(MainSheet1).Cells(Rows.Count, 4).End(xlUp).Row
If WorksheetFunction.CountIf(Worksheets(MainSheet1).Range("E13", "E" & k), zaiban2) >= 1 Then
tyouhuku = 1
mukou = 1
Call Sound1
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "在番" & zaiban2 & "は" _
& vbLf & "重複したので" & vbLf & "登録されませんでした"
Worksheets(MainSheet1).Range("B7").Interior.Color = RGB(255, 255, 50)
End If
For i = 13 To k
If tyouhuku = 0 And Worksheets(MainSheet1).Cells(i, 5).Value = "" Then
tyouhuku = 1
mukou = 1
Call BeepAPI(3500, 300)
Worksheets(MainSheet1).Cells(i, 5).Value = zaiban2
Worksheets(MainSheet1).Range("B7").Font.Size = 18
Worksheets(MainSheet1).Range("B7").Interior.ColorIndex = 0
If i > 31 Then
Worksheets(MainSheet1).PageSetup.PrintArea = "A1:F" & i + 1
End If
End If
Next i
End If

If mukou = 0 And Len(zaiban) < 15 Then
mukou = 1
Call Sound1
Worksheets(MainSheet1).Range("B7").Font.Size = 11
Worksheets(MainSheet1).Range("B7").Value = "在番" & zaiban & "は" _
& vbLf & "IRIS上存在しないので" & vbLf & "登録されませんでした"
Worksheets(MainSheet1).Range("B7").Interior.Color = RGB(255, 100, 100)
End If

Range("B7").Select
Application.ScreenUpdating = True
End Sub


レンタル掲示板
7件の内、新着の記事から10件ずつ表示します。

お知らせ · よくある質問(FAQ) · お問合せ窓口 · teacup.レンタル掲示板

© GMO Media, Inc.