オートフィルタで抽出した値をリストボックスに代入する為の
コードがあります。
前任者が書いたコードですが、何とか動作を確認しながら
変更しようとしたのですが、わかりませんでした。
やりたいこと
Application.Intersect(SS, SS.Offset(1)).Copyからxに格納した
値をmyList(i, 1) = xでリストボックスに入れたい。
問題点
For i = 0 To UBound(v) - 1
.Item(v(i)) = .Item(v(i)) + 1 'アイテムのカウント
Next
上記の後に
For Each v In .Keys
i = i + 1
myList(i, 0) = v '8行目の値
myList(i, 1) = x '9行目の値を入れたい
myList(i, 2) = .Item(v) '8行目のカウント数
Next
が実行される際にｖの値が重複を除いて、順番にリストに
入る動作が理解できません。
どなたかアドバイスお願いします。
Private Sub ComboBox1_Change()
Dim 開始日 As Date
Dim 終了日 As Date
Dim i, ii As Long, v, x As Variant
Dim Sh1 As Worksheet
Set Sh1 = Sheets("日報")
Set RR = Sh1.Range("A4").CurrentRegion
Set CC = RR.Columns(8)
Set SS = RR.Columns(9)
開始日 = DateValue(ComboBox1.Value)
終了日 = DateSerial(Year(開始日), Month(開始日) + 1, Day(開始日)) - 1
RR.Worksheet.AutoFilterMode = False ' B列 開始日から月末までの期間を抽出
RR.AutoFilter Field:=1, _
Criteria1:=">=" & 開始日, Operator:=xlAnd, _
Criteria2:="<=" & 終了日
Application.Intersect(CC, CC.Offset(1)).Copy '8行目をコピー
With New DataObject
.GetFromClipboard
v = Split(.GetText, vbCrLf) 'vに代入
Application.Intersect(SS, SS.Offset(1)).Copy '9行目をコピー
.GetFromClipboard
x = Split(.GetText, vbCrLf) 'xに代入
End With
With CreateObject("Scripting.Dictionary")
For i = 0 To UBound(v) - 1
.Item(v(i)) = .Item(v(i)) + 1 'アイテムのカウント
Next
ReDim myList(1 To .Count, 2)
i = 0
For Each v In .Keys
i = i + 1
myList(i, 0) = v '8行目の値
myList(i, 1) = x '9行目の値を入れたい
myList(i, 2) = .Item(v) '8行目のカウント数
Next
ListBox1.ColumnCount = 3
ListBox1.List = myList()
End With
RR.Worksheet.AutoFilterMode = False
RR.Worksheet.Application.CutCopyMode = False
End Sub
よろしくお願いします。
抜粋のコードをメモリーに負荷をかけない処理に変えたいのです。
下記は二つのファイルの構成を比較して（OLDBOOKのシートをNEWBOOKと同じ構成にする）追加、削除、並び替えを行うというものです。
しかし、メモリーの問題でシート数が30を超えると（環境によっては40枚位まではOK）Sheets.Countが狂い結果エラーに結び付くのです。
そこで、メモリーの負担を軽くするため、一気に配列に呼び込むのではなく、遅くなってもいいので、一つずつ比較するやりかたをご教示願えないかという次第です。
なお補足ですが、シートは関数などがぎっしり書き込まれているので、重いものなのです。それをBOOKに出来れば100枚位まで入るようにしたいのです。
ネット上で「一つのBOOKに何枚までシートを挿入出来るか？」というのを見ましたが、やはりメモリーに依存し（物理メモリーではなく）空のシートなら65000枚とかまででもOKですが、重いシートだと30枚位からダメになるとありましたので、実は今回の省略の前の部分でシートをCopy Afterで別BOOKに追加していくという形が有ったのですがここでもエラーでした。その内容はやはりSheets.Countが30を過ぎたら狂い（50枚入れる指示にもかかわらず31枚目を挿入時、シートカウントが7とかに戻ってしまう）そこで必要な枚数をCopy Afterで挿入して行かずに、先に空シートを必要な枚数作らせたBOOKのシートをまとめて、今回のシートを貼り付ける作業に変えたところ、100枚でもOKになり、そこはクリアしたのですが、今回の抜粋の所で引っかかってしまいました。
同じように遅くなっても軽い処理に下記コードを直したいのです。助けて下さい。
Dim NEWBOOK As Workbook
Dim OLDBOOK As Workbook
Dim shSrc As Object
Dim shDst As Object
～省略 ～
'現在の再計算モードの取得
iOldCalculation = Application.Calculation
'再計算モードを手動に設定
Application.Calculation = xlManual
'*****ここから比較*****
' // まず NEWBOOK にあって OLDBOOK にないシートをOLDBOOK に複写
For Each shSrc In NEWBOOK.Sheets
On Error Resume Next
Set shDst = OLDBOOK.Sheets(shSrc.Name)
On Error GoTo 0
If shDst Is Nothing Then
shSrc.Copy After:=OLDBOOK.Sheets(OLDBOOK.Sheets.Count) ←ここで実行時エラー（1004 コピー先の行数が足りないため～）
End If
Set shDst = Nothing
Next
' // 続いてNEWBOOK になくてOLDBOOK にあるシートをOLDBOOK から削除
For Each shDst In OLDBOOK.Sheets
On Error Resume Next
Set shSrc = NEWBOOK.Sheets(shDst.Name)
On Error GoTo 0
If shSrc Is Nothing Then
shDst.Delete
End If
Set shSrc = Nothing
Next
' // シート並べ替え
For Each shDst In OLDBOOK.Sheets
shDst.Move Before:=OLDBOOK.Sheets(NEWBOOK.Sheets(shDst.Name).Index)
shDst.Protect DrawingObjects:=True, Contents:=True, UserInterfaceOnly:=True
Next
'再計算モードの復元
Application.Calculation = iOldCalculation
NEWBOOK.Close (False) '有無を言わずに保存せず閉じる
～省略 ～
エクセルファイルシートをセミコロン区切りのテキストファイルに変換して出力したいです。
エクセル2002では以下のVBAで書いたマクロがちゃんと動いてTABをセミコロンに置換できますが、エクセル2003では置換ができなくてデータとデータの間にTABまま出力されます。
Public Sub ExportWorksheetWithCustomDelimiter( _
ByVal SourceWorksheet As Variant, _
ByVal FilePath As String, _
ByVal Delimiter As String)
' Exports the source worksheet as a text file with a custom field delimiter.
' ExportWorksheetWithCustomDelimiter(SourceWorksheet, FilePath, Delimiter)
' SourceWorksheet - The name of or a reference to a worksheet.
' FilePath - The full path to the export file.
' Delimiter - One or more characters to use as the field delimiter.
Dim DisplayAlerts As Boolean
Dim FileNumber As Long
Dim FileData As String
If VarType(SourceWorksheet) = vbString Then SourceWorksheet = ActiveWorkbook.Sheets(SourceWorksheet).Name
' Create copy of source worksheet in new workbook
Sheet1.Copy
' Save copy as tab delimited text file and close
DisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=FilePath, FileFormat:=xlText
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = DisplayAlerts
' Read file into string variable and delete file
FileNumber = FreeFile
'Open FilePath For Binary Access Read Write As FileNumber
Open FilePath & ".txt" For Binary Access Read Write As FileNumber
FileData = StrConv(InputB(LOF(FileNumber), FileNumber), vbUnicode)
Close FileNumber
Kill FilePath & ".txt"
' Replace all tabs with special character
FileData = Replace(FileData, Chr(9), Delimiter)
' Right modified text back out to same file
Open FilePath For Binary Access Read Write As FileNumber
Put FileNumber, , FileData
Close FileNumber
End Sub
上のマクロの実行後の結果は次と同じです。
エクセル2002からマクロの実行結果：AAA;BBB;CCC;DDD;EEE;FFF
エクセル2003からマクロの実行結果：AAA BBB CCC DDD EEE FFF
解決方法を教えてください。
ぜひよろしくお願いします。
ありがとうございます。
よろしくお願いします。
抜粋のコードをメモリーに負荷をかけない処理に変えたいのです。
下記は二つのファイルの構成を比較して（OLDBOOKのシートをNEWBOOKと同じ構成にする）追加、削除、並び替えを行うというものです。
しかし、メモリーの問題でシート数が30を超えると（環境によっては40枚位まではOK）Sheets.Countが狂い結果エラーに結び付くのです。
そこで、メモリーの負担を軽くするため、一気に配列に呼び込むのではなく、遅くなってもいいので、一つずつ比較するやりかたをご教示願えないかという次第です。
なお補足ですが、シートは関数などがぎっしり書き込まれているので、重いものなのです。それをBOOKに出来れば100枚位まで入るようにしたいのです。
ネット上で「一つのBOOKに何枚までシートを挿入出来るか？」というのを見ましたが、やはりメモリーに依存し（物理メモリーではなく）空のシートなら65000枚とかまででもOKですが、重いシートだと30枚位からダメになるとありましたので、実は今回の省略の前の部分でシートをCopy Afterで別BOOKに追加していくという形が有ったのですがここでもエラーでした。その内容はやはりSheets.Countが30を過ぎたら狂い（50枚入れる指示にもかかわらず31枚目を挿入時、シートカウントが7とかに戻ってしまう）そこで必要な枚数をCopy Afterで挿入して行かずに、先に空シートを必要な枚数作らせたBOOKのシートをまとめて、今回のシートを貼り付ける作業に変えたところ、100枚でもOKになり、そこはクリアしたのですが、今回の抜粋の所で引っかかってしまいました。
同じように遅くなっても軽い処理に下記コードを直したいのです。助けて下さい。
Dim NEWBOOK As Workbook
Dim OLDBOOK As Workbook
Dim shSrc As Object
Dim shDst As Object
～省略 ～
'現在の再計算モードの取得
iOldCalculation = Application.Calculation
'再計算モードを手動に設定
Application.Calculation = xlManual
'*****ここから比較*****
' // まず NEWBOOK にあって OLDBOOK にないシートをOLDBOOK に複写
For Each shSrc In NEWBOOK.Sheets
On Error Resume Next
Set shDst = OLDBOOK.Sheets(shSrc.Name)
On Error GoTo 0
If shDst Is Nothing Then
shSrc.Copy After:=OLDBOOK.Sheets(OLDBOOK.Sheets.Count) ←ここで実行時エラー（1004 コピー先の行数が足りないため～）
End If
Set shDst = Nothing
Next
' // 続いてNEWBOOK になくてOLDBOOK にあるシートをOLDBOOK から削除
For Each shDst In OLDBOOK.Sheets
On Error Resume Next
Set shSrc = NEWBOOK.Sheets(shDst.Name)
On Error GoTo 0
If shSrc Is Nothing Then
shDst.Delete
End If
Set shSrc = Nothing
Next
' // シート並べ替え
For Each shDst In OLDBOOK.Sheets
shDst.Move Before:=OLDBOOK.Sheets(NEWBOOK.Sheets(shDst.Name).Index)
shDst.Protect DrawingObjects:=True, Contents:=True, UserInterfaceOnly:=True
Next
'再計算モードの復元
Application.Calculation = iOldCalculation
NEWBOOK.Close (False) '有無を言わずに保存せず閉じる
～省略 ～
下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。
このプログラムをシートから実行した所
エラー：400『既にフォームは表示されています。モーダルにできません。』
なるものが表示されてしまいます。
またコードを記述する所から実行しますと
実行時エラー：１００４『アプリケーション定義またはオブジェクト定義のエラー』
となってしまいます。
私の努力が足りないのは重々承知ですが、解決する事が出来ません。
皆様のお力を借りることが出来たらと思い投稿しました。
宜しくお願い致します。
Sub syoutotumen()
Dim i As Long
Dim j As Long
Dim k As Long
Dim kyori As Long
Dim n As Integer
n = 1
i = 1
j = 1
k = 1
Const cnsYEN = "\"
Dim xlAPP As Application
Dim objWBK As Workbook
Dim strPATHNAME As String
Dim strFILENAME As String
strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理\"
If strPATHNAME = "" Then Exit Sub
strFILENAME = Dir(strPATHNAME & "dem******", vbNormal)
If strFILENAME = "" Then
MsgBox "このフォルダにはExcelワークブックは存在しません"
Exit Sub
End If
Set xlAPP = Application
With xlAPP
.ScreenUpdating = False
.EnableEvents = Fales
.EnableCancelKey = xlErrorHandler
.Cursor = xlWait
End With
Set WS1 = Worksheets("sheet1")
Range("A1") = "0"
Range("A2") = "1"
Range("A1:A2").Select
Selection.AutoFill Destinaton:=Range("A1:A512")
Do While strFILENAME <> ""
DoEvents
If swESC = True Then
If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then
GoTo Button1_Click_Exit
Else
swESC = False
End If
End If
xlAPP.StatusBar = trFILENAME & "処理中..."
Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True)
Do
If Cells(i, 2) = 255 Then Exit Do
i = i + 1
Loop
Do
If Cells(j, 3) = 255 Then Exit Do
j = j + 1
Loop
Do
If Cells(k, 4) = 255 Then Exit Do
k = k + 1
Loop
kyori = (i + j + k - 21) / 3
WS1.Cells(n, 2) = kyori
n = n + 1
i = 1
j = 1
k = 1
objWBK.Close savechanges:=False
strFILENAME = Dir
Loop
GoTo Button1_Click_Exit
Button1_Click_ESC:
If Err.Number = 18 Then
swESC = True
Resume
ElseIf Err.Number = 1004 Then
Resume Next
Else
MsgBox Err.Description
End If
Button1_Click_Exit:
With xlAPP
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
.EnableCancelKey = xlInterrupt
.Cursur = xlDefault
Set objWBK = Nothing
Set xlAPP = Nothing
End With
End Sub
簡単な例ですが、例えばB列にあるデータの平均値を求めるときに以下のようにしています。
sub 平均計算()
Dim X(1 To 1000, 1 To 1) As Variant, i as Integer
For i = 10 To 1000
X(i, 1) = WorksheetFunction.Average _
(Range(Cells(i - 9, 2), Cells(i, 2)))
Next
Range(Cells(1, 1), Cells(1000, 1)) = X
End Sub
ここで処理速度改善のため、B列のデータを別の配列変数Yに格納してから平均値を求めるというようなことをしたいのですが、そんなことは可能でしょうか？イメージとしてはこんな感じです。
Y = Range(Cells(1, 2), Cells(1000, 2))
for i = 1 to 1000
X(i, 1) = WorksheetFunction.Average _
(Range(Y(i - 9, 2), Y(i, 2)))
Next
当然これはエラーになってしまいますが、このようなことを可能にする方法があれば、どなたか教えてください！よろしくお願いします。
簡単な例ですが、例えばB列にあるデータの平均値を求めるときに以下のようにしています。
sub 平均計算()
Dim X(1 To 1000, 1 To 1) As Variant, i as Integer
For i = 10 To 1000
X(i, 1) = WorksheetFunction.Average _
(Range(Cells(i - 9, 2), Cells(i, 2)))
Next
Range(Cells(1, 1), Cells(1000, 1)) = X
End Sub
ここで処理速度改善のため、B列のデータを別の配列変数Yに格納してから平均値を求めるというようなことをしたいのですが、そんなことは可能でしょうか？イメージとしてはこんな感じです。
Y = Range(Cells(1, 2), Cells(1000, 2))
for i = 1 to 1000
X(i, 1) = WorksheetFunction.Average _
(Range(Y(i - 9, 2), Y(i, 2)))
Next
当然これはエラーになってしまいますが、このようなことを可能にする方法があれば、どなたか教えてください！よろしくお願いします。
簡単な例ですが、例えばB列にあるデータの平均値を求めるときに以下のようにしています。
sub 平均計算()
Dim X(1 To 1000, 1 To 1) As Variant, i as Integer
For i = 10 To 1000
X(i, 1) = WorksheetFunction.Average _
(Range(Cells(i - 9, 2), Cells(i, 2)))
Next
Range(Cells(1, 1), Cells(1000, 1)) = X
End Sub
ここで処理速度改善のため、B列のデータを別の配列変数Yに格納してから平均値を求めるというようなことをしたいのですが、そんなことは可能でしょうか？イメージとしてはこんな感じです。
Y = Range(Cells(1, 2), Cells(1000, 2))
for i = 1 to 1000
X(i, 1) = WorksheetFunction.Average _
(Range(Y(i - 9, 2), Y(i, 2)))
Next
当然これはエラーになってしまいますが、このようなことを可能にする方法があれば、どなたか教えてください！よろしくお願いします。
お世話になります。
『記入可能セルに記入させ、「送信」フォームを押すと、１箇所文字の色が変わり、添付されてメールで送られる。』というマクロを組みました。
その後、
シートがたくさんあるので、ＶＢＡを使って、一度にシートの保護、非保護を行いました。
以下はその記述文です。
Sub 保護()
Dim Ws As Worksheet
For Each Ws In Worksheets
Ws.Protect Password:=111
Next
End Sub
Sub 保護解除()
Dim Ws As Worksheet
For Each Ws In Worksheets
Ws.Unprotect Password:=111
Next
End Sub
この保護のマクロを使うと、記入可能なセルは、セルの書式設定の保護タブからチェックをはずしており全く問題ないのですが、
「色が変わる」という設定がエラーになります。
どのようにしたら、色が変わるのも許可されるマクロになるのでしょうか。
ご教示お願いいたします。
お世話になります。
『記入可能セルに記入させ、「送信」フォームを押すと、１箇所文字の色が変わり、添付されてメールで送られる。』というマクロを組みました。
その後、
シートがたくさんあるので、ＶＢＡを使って、一度にシートの保護、非保護を行いました。
以下はその記述文です。
Sub 保護()
Dim Ws As Worksheet
For Each Ws In Worksheets
Ws.Protect Password:=111
Next
End Sub
Sub 保護解除()
Dim Ws As Worksheet
For Each Ws In Worksheets
Ws.Unprotect Password:=111
Next
End Sub
この保護のマクロを使うと、記入可能なセルは、セルの書式設定の保護タブからチェックをはずしており全く問題ないのですが、
「色が変わる」という設定がエラーになります。
どのようにしたら、色が変わるのも許可されるマクロになるのでしょうか。
ご教示お願いいたします。
