先日この欄で教えていただいたのですが、
確認を忘れてしまい、うまくゆかないので再質問させていただきます。
複数列の複数行（例A列3行～F列20行）に関数式によるデータが入っています。
これを縦１列に配置替えしてテキストにoutputするということで次のVBAを教えてもらったのですが
途中で止まってしまいました。お知恵を貸してください。
Sub closs()
Dim myRng As Range
Dim i As Long
Sheets("データシート").Select
Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
Sheets("貼り付け").Select
For i = 1 To myRng.Columns.Count
Range("A1").Offset((myRng.Rows.Count) * (i - 1)).Resize(myRng.Rows.Count) _
= myRng.Columns(i).Value
Next
End Sub
※例としてA列3行～F列20行を１グループとして縦１列に配列替えをしてテキストに出力する。
※マウスによるカーソル位置をデータトップのA3またはそれより上の空欄において実行する。
※グループの途中（例A21～F24）を空欄（関数式なし）として次のグループが存在し、グループか存在する場合同じ作業を繰り返し
別のテキストにoutputする。
※列を増やしたい場合の対応もできるようにしておく。
よろしくお願いします。
いつもお世話になります。
すみません、下記のコードで 、DO～While LOOP ステートメントを解除して、一回だけ
実施するようなコードに修正したいのですが、自分ではうまく修正できません。
どうか修正したコードを教えていただけないでしょうか。
Sub ShowBarCode()
Dim xlAPP As Application
Dim GYO As Long
Dim objOLEObject As OLEObject
Dim objBarCode As BARCODELib.BarCodeCtrl
Dim lngLeft As Long
Dim lngTop As Long
Dim intHeight As Integer
Dim intWidth As Integer
Dim sh As Worksheet
Set xlAPP = Application
xlAPP.ScreenUpdating = False
xlAPP.Calculation = xlCalculationManual
xlAPP.Interactive = False
On Error GoTo ERROR_EXIT
GYO = 66
Do While Cells(GYO, 99).Value <> ""
Cells(GYO, 100).Select
' 現在セルの位置を取得
With ActiveCell
lngLeft = .Left + .Width * 0.05
lngTop = .Top + 1
intHeight = .height * 0.7
intWidth = .Width * 6.9
End With
' 現在セルにバーコードを貼付ける
ActiveSheet.OLEObjects.Add(ClassType:="BARCODE.BarCodeCtrl.1", _
Link:=False, DisplayAsIcon:=False, _
Left:=lngLeft, Top:=lngTop, Width:=intWidth, _
height:=intHeight).Select
Set objOLEObject = Selection
Set objBarCode = objOLEObject.Object
With objOLEObject
.Visible = False ' 一旦消去
.Placement = 2
.Visible = True ' 表示
End With
With objBarCode
.Style = 2 ' JAN-13
.SubStyle = 0
.Validation = 1 ' C/D修正有り
.ShowData = 0 ' 数値表示なし
.Value = Cells(GYO, 100).Value
.Refresh
End With
Cells(GYO, 100).FormulaR1C1 = "=LEFT(RC1,7)&"" ""&RIGHT(RC1,6)"
GYO = GYO + 1
Loop
Cells(1, 1).Select
xlAPP.Interactive = True
xlAPP.Calculation = xlCalculationAutomatic
xlAPP.ScreenUpdating = True
Exit Sub
ERROR_EXIT:
xlAPP.Interactive = True
xlAPP.Calculation = xlCalculationAutomatic
xlAPP.ScreenUpdating = True
MsgBox Err.Description
End Sub
お世話になります。
Ｅｘｃｅｌ2007でタイムレポートを作成しております。
ＶＢＡで構文を作成しました。
30分以上で、残業発生。以降10分単位。29分は残業ではないというのが条件であります。
30分なら０：30 29分なら表示させない。35分ら0：30、40分なら0：40といった形です。
30分以上なら、普通残業を計算をするという構文を書いたのですが、
10分以上から0：10と表示されてしまいます。
8：30が定時、17：00が終了です。7：45が就業時間です。
普通残業は、17：00から22：00です。8：30分より早く来ても、8：30分から計算します。
たとえば、8：30 17：30なら、 7：45 0：30、 8：30 17：45なら 7：45 0：40です。
17：29なら普通残業は、表示させないようにしたいと思います。
→現状、0：20と表示されてしまいます。
-----------------------------------------------------------------------------
Public Sub CmpKintaiTime(prmINTIM, prmOUTTIM, prmKNMKBN, rtnSYUGYO, rtnHAYZAN, rtnFUTZAN, rtnSINZAN, rtnTIKOKU, rtnSOUTAI, rtnKYUZAN, rtnKYUSIN)
'**************************************************
' 勤怠時間 算出
'**************************************************
On Error GoTo ErrorTrap
Dim wINTIM As Integer
Dim wOUTTIM As Integer
Dim wSTRTIM As Integer
Dim wENDTIM As Integer
Dim wSYUGYO As Variant
Dim wFUTZAN As Variant
Dim wSINZAN As Variant
Dim wHAYZAN As Variant
Dim wTIKOKU As Variant
Dim wSOUTAI As Variant
Dim wTIKOKUw As Variant
Dim wSOUTAIw As Variant
Dim wKYUZAN As Variant
Dim wKYUSIN As Variant
Dim wLower As Integer
Dim wUpper As Integer
Dim wIdx As Integer
If IsTime(prmINTIM) = False Then
GoTo ExitTrap
End If
If IsTime(prmOUTTIM) = False Then
GoTo ExitTrap
End If
'時刻を分換算
wINTIM = Hour(prmINTIM) * 60 + Minute(prmINTIM)
wOUTTIM = Hour(prmOUTTIM) * 60 + Minute(prmOUTTIM)
'日付が変わった時刻は24時間加算
If wINTIM >= wOUTTIM Then
wOUTTIM = wOUTTIM + (24 * 60)
End If
If wOUTTIM > khnENDTIM Then
If wOUTTIM <= khnSTRFZN Then
wOUTTIM = khnENDTIM
Else
If wOUTTIM > khnENDFZN Then
If wOUTTIM <= khnSTRSZN Then
wOUTTIM = khnENDFZN
Else
If wOUTTIM > khnENDSZN Then
wOUTTIM = khnENDSZN
End If
End If
End If
End If
End If
wSYUGYO = Null
wFUTZAN = Null
wSINZAN = Null
wHAYZAN = Null
wTIKOKU = Null
wSOUTAI = Null
'就業時間算出
If wINTIM < khnSTRTIM Then
wSTRTIM = khnSTRTIM
Else
wSTRTIM = wINTIM
End If
If wOUTTIM > khnENDTIM Then
wENDTIM = khnENDTIM
Else
wENDTIM = wOUTTIM
End If
If wENDTIM > wSTRTIM Then
wSYUGYO = wENDTIM - wSTRTIM
Else
wSYUGYO = 0
End If
If prmKNMKBN <> 1 Then '平日のみ
'遅刻
If wINTIM > khnSTRTIM Then
wTIKOKU = wINTIM - khnSTRTIM
End If
'早退
If wOUTTIM < khnENDTIM Then
wSOUTAI = khnENDTIM - wOUTTIM
End If
End If
'早出残業算出 (始業時刻より早出残業判断分前に出勤した場合、早出を算出)
If wINTIM <= (khnSTRTIM - khnHAYFUN) Then
wHAYZAN = khnSTRTIM - wINTIM
End If
'普通残業算出
wFUTZAN = wOUTTIM - wINTIM - wSYUGYO
If wFUTZAN >= 30 Then
wFUTZAN = wOUTTIM - wINTIM - wSYUGYO
End If
ご教授くださいますようお願い申し上げます。
文章が長くて、最後まで読んでくださってありがとうございます。
お手数をおかけしますが、ご教授くださいますようお願いいたします。
下記のコードを、多数のユーザーに配布するため、自動的にPERSONAL.XLSのModule 1に登録させられるようなコードを教えていただけるとありがたいです。よろしくお願いいたします。
■お願いしたいこと
(1)下記コード「passget」と「mailsheetopen」を自動的にPERSONAL.XLSのModule 1に追記するコードを教えてほしい
(2)さらに「mailsheetopen」のコマンドをツールバー右下に自動的に表示させられるようにしたい
Private sub passget()
Dim TempObject As MSForms.DataObject
Set TempObject = New MSForms.DataObject
With TempObject
.SetText "<<http://" & ActiveWorkbook.FullName & ">>"
.PutInClipboard
End With
Set TempObject = Nothing
End Sub
'------------------------------------------------------------
Sub mailsheetopen()
On Error Resume Next
Call passget
Dim target_dir As String
Dim target_file As String
Dim target_sheet As String
target_dir = "C:\Users\new\Desktop"
target_file = "rensyu.xls"
target_sheet = "rensyu"
'ブックを開く
Workbooks.Open Filename:=target_dir & "\" & target_file
'シートを指定
Sheets(target_sheet).Select
'セルを指定
Range("B6").PasteSpecial
End Sub
質問させていただきます。
現在、エクセルにて
sheet1に帳簿内容入力画面
sheet2に入力画面の項目を反映した印刷用帳簿
というものを作成しています。
その中で、sheet1にチェックボックスを設置し、チェックONでsheet2任意の場所に
オートシェイプの楕円を表示(チェックOFFで楕円は消える)させたいのですが、
うまくいきません。
試しにsheet1上にチェックボックス・楕円を設置し、
-------------------------------------------
Sub test01()
With ActiveSheet
If .CheckBoxes(Application.Caller).Value = xlOn Then
.Shapes("楕円１").Visible = True
Else
.Shapes("楕円１").Visible = False
End If
End With
End Sub
-------------------------------------------
とイベント設定をしたところ、sheet1上ではチェックON/OFFで楕円の
表示/非表示ができました。
しかし、実際sheet1にチェックボックス、2に楕円と設置すると「オブジェクトが存在しません」と
エラーになってしまいます。
IF関数のような（シート名!セル名）的に楕円の場所を指定しなければいけないのかな？と
思い、色々試してみたのですが実現できませんでした。
勉強不足で恐縮なのですが、詳しい方アドバイスをいただきたいです。
