エクセル(Excel)&ワード(Word)質問掲示板

より見やすく使いやすいエクセル掲示板を目指し、新たにエクセルの質問掲示板を開設いたしました。 これに伴い、当サイトでは今後、新規投稿はできなくなります。(閲覧は当面可能です。)
今後は新掲示板をご利用いただきますよう宜しくお願い致します。今後ともよろしくお願い致します。
○新掲示板
エクセル(Excel)解決掲示板

エクセル・ワードの基本操作に関する質問や関数やマクロの使い方などエクセルとワードに関する質問掲示板。
Welcome Guest 
メインメニュー
ログイン
ユーザー名:

パスワード:


パスワード紛失

はじめまして。マクロつくってみました。

このトピックの投稿一覧へ

なし はじめまして。マクロつくってみました。

msg# 1
depth:
0
前の投稿 - 次の投稿 | 親投稿 - 子投稿なし | 投稿日時 2009-10-20 10:35
yshukusima 
Option Explicit

Sub jfkjfd()
Dim MyBar As CommandBar
Dim topnm As CommandBarControl
Dim tip As CommandBarControl
Dim tipk As CommandBarControl
Dim tta As CommandBarControl
Dim gha As CommandBarControl
Dim ghak As CommandBarControl
Dim ggga As CommandBarControl

Set MyBar = CommandBars.Add("y", msoBarTop)
MyBar.Visible = True
Set topnm = CommandBars("y").Controls.Add(msoControlPopup)
topnm.Caption = "データ入力"

topnm.OnAction = "proc1"

Set tip = CommandBars("y").Controls.Add(msoControlPopup)
tip.Caption = "ランク"

tip.OnAction = "proc2"

Set tipk = CommandBars("y").Controls.Add(msoControlPopup)
tipk.Caption = "csv化"

tipk.OnAction = "proc3"

Set tta = CommandBars("y").Controls.Add(msoControlPopup)
tta.Caption = "行列入れ替え"

tta.OnAction = "proc4"
Set gha = CommandBars("y").Controls.Add(msoControlPopup)
gha.Caption = "日付"

gha.OnAction = "proc5"
Set ghak = CommandBars("y").Controls.Add(msoControlPopup)
ghak.Caption = "画像化"

ghak.OnAction = "proc6"
Set ggga = CommandBars("y").Controls.Add(msoControlPopup)
ggga.Caption = "画像化& 近似式"

ggga.OnAction = "proc7"
End Sub
Sub proc1()
Dim r1 As Range
Dim WS As Variant
Dim i As Integer
Dim f As Integer
Dim s As Integer
Dim NowDate As String
Dim Month As String
Dim Week As String
Dim GetWeek As Integer
Dim FirstWeek As String
Dim k As Integer
Dim h As Integer
Dim myRng As Range
Dim myr As Range
Dim ka As Integer
Dim llo As Long

Dim kg As Integer

Dim j As Integer
Dim r(100) As Integer
Dim l As Integer
Dim q As Integer
Dim ks As String
Dim sd As String
Dim kk As Integer

Dim hj As Integer
Dim sf As String
Dim sg As String
Dim sf1(25) As String
Dim sg1(25) As String





ka = 1
Range("A3") = "野菜"
Range("A4") = "果物"
Range("A5") = "肉"
Range("A6") = "お菓子"
Range("A7") = "合計"
Range("ag1") = "合計"
Range("ah1") = "平均"
Range("ai1") = "最大値"
Range("aj1") = "最小値"


With Worksheets("Sheet1").Range("A3:AF3")
Set r1 = .Find((""), LookIn:=xlValues)

r1.Select
End With
If (r1 = Range("b3")) Then
FirstWeek = InputBox("月の最初を入力")
GetWeek = Weekday(DateValue(FirstWeek))
Month = Mid(FirstWeek, 6, 2)
ks = Mid(FirstWeek, 1, 4)

Select Case GetWeek
Case 1
Week = "日"
Case 2
Week = "月"

Case 3
Week = "火"
Case 4
Week = "水"
Case 5
Week = "木"

Case 6
Week = "金"
Case 7
Week = "土"
End Select

If ks Mod 4 = 0 Then
If Month = "01" Or Month = "03" Or Month = "05 " Or Month = "07" Or Month = "09" Or Month = "11" Or Month = "12" Then
Set myRng = Range("b2:Af2")

GoTo aa:
ElseIf Month = "02" Then
Set myRng = Range("b2:ad2")

GoTo aa:
ElseIf Month = "04" Or Month = "06" Or Month = "08 " Or Month = "10" Then
Set myRng = Range("b2:Ae2")

GoTo aa:
End If
aa:
With myRng.Cells(1)
.Value = ka
.AutoFill Destination:=myRng, Type:=xlFillSeries
End With
Set myRng = Nothing
If Month = "01" Or Month = "03" Or Month = "05 " Or Month = "07" Or Month = "09" Or Month = "11" Or Month = "12" Then
Set myr = Range("b1:af1")

GoTo ab:
ElseIf Month = "02" Then
Set myr = Range("b1:ad1")


GoTo ab:
ElseIf Month = "04" Or Month = "06" Or Month = "08 " Or Month = "10" Then
Set myr = Range("b1:ae1")

GoTo ab:
End If



ab:

With myr.Cells(1)
.Value = Week
.AutoFill Destination:=myr, Type:=xlFillSeries
End With
Set myr = Nothing






Else
If Month = "01" Or Month = "03" Or Month = "05 " Or Month = "07" Or Month = "09" Or Month = "11" Or Month = "12" Then
Set myRng = Range("b2:Af2")

GoTo ac:
ElseIf Month = "02" Then
Set myRng = Range("b2:Ad2")

GoTo ac:
ElseIf Month = "04" Or Month = "06" Or Month = "08 " Or Month = "10" Then
Set myRng = Range("b2:Ae2")

GoTo ac:
End If
ac:
With myRng.Cells(1)
.Value = ka
.AutoFill Destination:=myRng, Type:=xlFillSeries
End With
Set myRng = Nothing
If Month = "01" Or Month = "03" Or Month = "05 " Or Month = "07" Or Month = "09" Or Month = "11" Or Month = "12" Then
Set myr = Range("b1:af1")

GoTo ad:
ElseIf Month = "02" Then
Set myr = Range("b1:ad1")


GoTo ad:
ElseIf Month = "04" Or Month = "06" Or Month = "08 " Or Month = "10" Then
Set myr = Range("b1:ae1")

GoTo ad:
End If



ad:

With myr.Cells(1)
.Value = Week
.AutoFill Destination:=myr, Type:=xlFillSeries
End With
Set myr = Nothing

End If


End If
kg = 2
For llo = 65 To 96
sd = "$" + Chr(llo) + "$" + "3"
If (kg >= 28) Then
sd = "$" + "A" + Chr(llo - 26) + "$" + "3"
End If
If (r1.Address = sd) Then
s = kg
End If
kg = kg + 1
Next





k = InputBox("日数入力")
For h = 1 To k * 4 Step 1
r(h) = InputBox("入力")

Next h
q = 0

s = s - 1
For i = 1 To k Step 1
For j = 1 To 4 Step 1



Cells(j + 2, s).Value = r(j + q * 4)




Next j
s = s + 1
q = q + 1

Next i



With Worksheets("Sheet1").Range("A1:AF7")
.Rows.AutoFit
.Columns.AutoFit
End With

For hj = 66 To 100
sf = Chr(hj) + "7"
sg = Chr(hj) + "3" + ":" + Chr(hj) + "6"
If (hj >= 91) Then
sf = "a" + Chr(hj - 26) + "7"
sg = "a" + Chr(hj - 26) + "3" + ":" + "a" + Chr(hj - 26) + "6"
End If
Range(sf) = Application.WorksheetFunction.Sum(Range(sg))
Next



i = 0


For hj = 71 To 77

sf1(i) = "A" + Chr(hj) + "3"
sf1(i + 1) = "A" + Chr(hj) + "4"

sg1(i) = "b" + "3" + ":" + "af" + "3"
sg1(i + 1) = "b" + "4" + ":" + "af" + "4"


i = i + 4
Next
j = 0
For hj = 71 To 77
sf1(j) = "A" + Chr(hj) + "5"
sf1(j + 1) = "A" + Chr(hj) + "6"
sg1(j) = "b" + "5" + ":" + "af" + "5"
sg1(j + 1) = "b" + "6" + ":" + "af" + "6"
j = j + 4
Next
For i = 0 To 1
Range(sf1(i)) = Application.WorksheetFunction.Sum(Range(sg1(i)))
Range(sf1(i + 4)) = Application.WorksheetFunction.Average(Range(sg1(i + 4)))

Range(sf1(i + 8)) = Application.WorksheetFunction.Max(Range(sg1(i + 8)))

Range(sf1(i + 12)) = Application.WorksheetFunction.Min(Range(sg1(i + 12)))
Next
For j = 0 To 1
Range(sf1(j)) = Application.WorksheetFunction.Sum(Range(sg1(j)))
Range(sf1(j + 4)) = Application.WorksheetFunction.Average(Range(sg1(j + 4)))

Range(sf1(j + 8)) = Application.WorksheetFunction.Max(Range(sg1(j + 8)))

Range(sf1(j + 12)) = Application.WorksheetFunction.Min(Range(sg1(j + 12)))
Next

With Worksheets("Sheet1").Range("A1:AF10")
.Rows.AutoFit
.Columns.AutoFit
End With
WS = Array("Sheet1", "Sheet2", "Sheet3")
Worksheets(WS).FillAcrossSheets Range:=Worksheets("Sheet1").Range("a1:af7")
Range("a1:aj7").Select
If (r1 = Range("B3")) Then
ActiveSheet.ChartObjects.Add(Left:=10, Top:=50, Width:=300, Height:=200).Select
ActiveChart.SetSourceData Source:=Range("A2:AF7")

ActiveSheet.ChartObjects(1).Select
ActiveChart.ChartType = xlLine
ActiveSheet.ChartObjects.Add(Left:=10, Top:=50, Width:=400, Height:=300).Select
ActiveChart.SetSourceData Source:=Range("A2:AF7")

ActiveSheet.ChartObjects(1).Delete
ActiveSheet.ChartObjects(1).Select
ActiveChart.ChartType = xlLine


Range("a1:aj7").Select

Selection.Borders.LineStyle = xlContinuous

Worksheets("Sheet2").Activate

ActiveSheet.ChartObjects.Add(Left:=10, Top:=50, Width:=300, Height:=200).Select
ActiveChart.SetSourceData Source:=Range("A2:AF7")

ActiveSheet.ChartObjects(1).Select
ActiveChart.ChartType = xlXYScatter
ActiveSheet.ChartObjects.Add(Left:=10, Top:=50, Width:=400, Height:=300).Select
ActiveChart.SetSourceData Source:=Range("A2:AF7")

ActiveSheet.ChartObjects(1).Delete
ActiveSheet.ChartObjects(1).Select
ActiveChart.ChartType = xlXYScatter
Range("a1:aj7").Select
Worksheets("Sheet3").Activate
ActiveSheet.ChartObjects.Add(Left:=10, Top:=50, Width:=300, Height:=200).Select
ActiveChart.SetSourceData Source:=Range("A2:AF7")

ActiveSheet.ChartObjects(1).Select
ActiveChart.ChartType = xlRadar
ActiveSheet.ChartObjects.Add(Left:=10, Top:=50, Width:=400, Height:=300).Select
ActiveChart.SetSourceData Source:=Range("A2:AF7")

ActiveSheet.ChartObjects(1).Delete
ActiveSheet.ChartObjects(1).Select
ActiveChart.ChartType = xlRadar
Range("a1:aj7").Select
Selection.Borders.LineStyle = xlContinuous
End If

With Worksheets("Sheet2").Range("a1:af7")
.Rows.AutoFit
.Columns.AutoFit
End With
With Worksheets("Sheet3").Range("a1:af7")
.Rows.AutoFit
.Columns.AutoFit
End With

End Sub
Sub proc2()
With Worksheets("Sheet1")
.Range("a3").AutoFilter field:=2, Criteria1:=10, Operator:=xlTop10Items
End With
End Sub


Sub bnghb()

Range("a1:af7").Select

Selection.Borders.LineStyle = xlContinuous


End Sub

Sub proc3()
'テストデータ F_Data01シート
Dim myRng As Range
Dim myFileName As String
Set myRng = Application.InputBox _
("保存する範囲を指定してください", , , , , , , 8)
If myRng Is Nothing Then Exit Sub
'[名前を付けて保存]ダイアログボックスを表示
myFileName = Application.GetSaveAsFilename _
(fileFilter:="CSVファイル (*.csv), *.csv")
If myFileName = "False" Then Exit Sub
Application.ScreenUpdating = False
With Worksheets.Add
myRng.Copy .Cells(1, 1)
.Move
End With
With ActiveWorkbook
.SaveAs Filename:=myFileName, FileFormat:=xlCSV
.Close False
End With
Application.ScreenUpdating = True
Set myRng = Nothing 'オブジェクトの解放
End Sub

Sub proc4()
Dim RG As Range
Dim Source As Integer
Dim dist As Range
Dim i As String

Set RG = Application.InputBox("", Type:=8)

RG.Select
Selection.Copy
i = InputBox("")
Range(i).Select
Selection.PasteSpecial Paste:=xlAll, Transpose:=True


End Sub
Sub proc5()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim p As Integer
Dim o As Integer
Dim r1 As Range
Dim jj As Integer
Dim s As Integer

Dim l As Integer
Dim e(6) As String
Dim r(6) As String
Dim d(6) As String
Dim h(6) As String



Dim f As Integer

Dim NowDate As String
Dim Month As String
Dim Week As String
Dim GetWeek As Integer
Dim FirstWeek As String

Dim q As Integer
Dim ks As String




FirstWeek = InputBox("月の最初を入力")
GetWeek = Weekday(DateValue(FirstWeek))
Month = Mid(FirstWeek, 6, 2)
ks = Mid(FirstWeek, 1, 4)


Select Case GetWeek

Case 1
Week = "日"
Case 2
Week = "月"

Case 3
Week = "火"
Case 4
Week = "水"
Case 5
Week = "木"

Case 6
Week = "金"
Case 7
Week = "土"
End Select

Range("f9").Select
ActiveCell.FormulaR1C1 = "1日"
Range("f10").Select
ActiveCell.FormulaR1C1 = "2日"

If ks Mod 4 = 0 Then

If Month = "01" Or Month = "03" Or Month = "05 " Or Month = "07" Or Month = "09" Or Month = "11" Then
Range("f9:f10").Select

Selection.AutoFill Destination:=Range("f9:f39"), Type:=xlFillDefault
Range("g9").Select

ActiveCell.FormulaR1C1 = Week
Selection.AutoFill Destination:=Range("g9:g39"), Type:=xlFillDefault
Range("g9:g39").Select

ElseIf Month = "02" Then
Range("f9:f10").Select
Selection.AutoFill Destination:=Range("f9:f37"), Type:=xlFillDefault
Range("g9").Select

ActiveCell.FormulaR1C1 = Week
Selection.AutoFill Destination:=Range("g9:g37"), Type:=xlFillDefault
Range("g9:g37").Select

Else
Range("f9:f10").Select
Selection.AutoFill Destination:=Range("f9:f38"), Type:=xlFillDefault
Range("g9").Select

ActiveCell.FormulaR1C1 = Week
Selection.AutoFill Destination:=Range("g9:g38"), Type:=xlFillDefault
Range("g9:g38").Select
End If

Else


If Month = "01" Or Month = "03" Or Month = "05 " Or Month = "07" Or Month = "09" Or Month = "11" Then
Range("f9:f10").Select
Range("f9").Select
Selection.AutoFill Destination:=Range("f9:f39"), Type:=xlFillDefault
ActiveCell.FormulaR1C1 = Week
Selection.AutoFill Destination:=Range("g9:g39"), Type:=xlFillDefault
Range("g9:g39").Select

ElseIf Month = "02" Then
Range("f9:f10").Select
Selection.AutoFill Destination:=Range("f9:f36"), Type:=xlFillDefault
Range("g9").Select

ActiveCell.FormulaR1C1 = Week
Selection.AutoFill Destination:=Range("g9:g36"), Type:=xlFillDefault
Range("g9:g36").Select

Else
Range("f9:f10").Select
Selection.AutoFill Destination:=Range("f9:f38"), Type:=xlFillDefault
Range("g9").Select

ActiveCell.FormulaR1C1 = Week
Selection.AutoFill Destination:=Range("g9:g38"), Type:=xlFillDefault
Range("g9:g38").Select
End If


End If


End Sub
Sub proc6()

Dim myRng1 As Range
Dim myRng2 As Range
Dim RG As Range

Set RG = Application.InputBox("", Type:=8)
'コピー元セル範囲
Set myRng2 = Range("c15") 'コピー先セル
'準備ここまで
RG.CopyPicture
myRng2.Select
myRng2.Parent.Pictures.Paste
Set RG = Nothing 'オブジェクトの解放
Set myRng2 = Nothing


End Sub


Sub proc7()
'H_Sample002で作成したグラフを使います
Dim myCht As Chart
Dim mySht As Worksheet
Dim myStr As String
Set mySht = ThisWorkbook.Worksheets(1) 'グラフのあるシート
Set myCht = mySht.ChartObjects(mySht.ChartObjects.Count).Chart
With myCht.SeriesCollection(1).Trendlines.Add _
(Type:=xlLinear, DisplayEquation:=True)
myStr = .DataLabel.Characters.Text
.Delete
End With
MsgBox myStr
Set mySht = Nothing 'オブジェクトの解放
Set myCht = Nothing



'H_Sample002で作成したグラフを使います
Dim myCht As Chart
Dim mySht As Worksheet
Dim myFileName As String
Set mySht = ThisWorkbook.Worksheets(1) 'グラフのあるシート
Set myCht = mySht.ChartObjects(mySht.ChartObjects.Count).Chart
myFileName = "myCht.jpg" 'ファイル名を指定
On Error Resume Next
Kill ThisWorkbook.Path & "\" & myFileName
On Error GoTo 0
'ファイル形式を指定する
myCht.Export _
Filename:=ThisWorkbook.Path & "\" & myFileName, Filtername:="JPG"
Set mySht = Nothing 'オブジェクトの解放
Set myCht = Nothing
End Sub
投票数:131 平均点:4.73
返信する

この投稿に返信する

題名
ゲスト名   :
投稿本文

投稿ツリー

  条件検索へ


スポンサーリンク
スポンサーリンク
エクセル・ワード質問/回答集 - クイズ・問題QUUS! - 無料英語学習 - 投資家・トレーダー掲示版
為替(FX)テクニカル分析入門 - エクセル(EXCEL)学習・入門 - Word(ワード)の使い方/活用・入門
Copy right(c) 2006-2010 エクセル&ワード質問掲示板 all right reserved