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

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

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

パスワード:


パスワード紛失

この前の改善しました。

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

なし この前の改善しました。

msg# 1
depth:
0
前の投稿 - 次の投稿 | 親投稿 - 子投稿なし | 投稿日時 2009-10-23 10:03
ysfukusima 
Option Explicit

Sub jfkjfd()
Dim MyBar As CommandBar
Dim topnm As CommandBarControl
Dim tip As CommandBarControl
Dim kse 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 kse = CommandBars("w").Controls.Add(msoControlPopup)
kse.Caption = "上書き保存"

kse.OnAction = "proc8"

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 Month As String
Dim Week As String
Dim GetWeek As String

Dim FirstWeek As String
Dim k As Integer
Dim h As Integer
Dim myRng As Range
Dim myr As Range
Dim ka As String

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





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 = WeekdayName(Weekday(DateValue(FirstWeek)))
Month = Mid(FirstWeek, 6, 2)
ks = Mid(FirstWeek, 1, 4)
Week = Mid(GetWeek, 1, 1)
ka = Mid(FirstWeek, 9, 10)

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")


Set myr = Range("b1:af1")
GoTo aa:
ElseIf Month = "02" Then
Set myRng = Range("b2:ad2")
Set myr = Range("b1:ad1")
GoTo aa:
ElseIf Month = "04" Or Month = "06" Or Month = "08 " Or Month = "10" Then
Set myRng = Range("b2:Ae2")

Set myr = Range("b1:ae1")
GoTo aa:
End If
aa:
With myRng.Cells(1)
.Value = ka
.AutoFill Destination:=myRng, Type:=xlFillSeries
End With
Set myRng = Nothing

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")
Set myr = Range("b1:af1")
GoTo ac:
ElseIf Month = "02" Then
Set myRng = Range("b2:ac2")
Set myr = Range("b1:ac1")
GoTo ac:
ElseIf Month = "04" Or Month = "06" Or Month = "08 " Or Month = "10" Then
Set myRng = Range("b2:Ae2")

Set myr = Range("b1:ae1")

GoTo ac:
End If
ac:
With myRng.Cells(1)
.Value = ka
.AutoFill Destination:=myRng, Type:=xlFillSeries
End With
Set myRng = Nothing

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

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
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 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 proc8()
Dim mywb As Workbook
Dim filen As String
Dim mtErr As Long
filen = Application.GetSaveAsFilename(, "Excel(ブック)(*.xls),*.xls)")
On Error Resume Next
Application.DisplayAlerts = False
mywb.SaveAs filen
Application.DisplayAlerts = True
mtErr = Err.Number
On Error GoTo 0

End Sub
投票数:73 平均点:5.89
返信する

この投稿に返信する

題名
ゲスト名   :
投稿本文

投稿ツリー

  条件検索へ


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