AIと戦って、あなたの人生のリスク診断 >>

Excel指定範囲をPDFにしたいのですが、
いろいろやりましたがうまくいきません。
わかる方お願いいたします。

dim r as range
set r =Range("a1:b5")
ここからわかりません
Application.FileDialog
r.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "dd"

A 回答 (1件)

Public Sub test()


Dim r As Range
Set r = Range("a1:b5")
r.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "dd"
End Sub

これだけでよくないですか?
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aと関連する良く見られている質問

Q合計処理

1月 2月 合計
リンゴ 100 100 200
バナナ 200 200 400
合計    300 300 600


各合計をVBAで配列を利用して処理できるかた
教えて下さい

Aベストアンサー

合計の欄は元々空白であったとしたら、

一例として。

Sub megu()
Dim i As Long
Dim j As Long
Dim v

v = Range("B2:D4").Value

For i = LBound(v, 1) To UBound(v, 1) - 1
For j = LBound(v, 2) To UBound(v, 2) - 1
v(i, UBound(v, 2)) = v(i, UBound(v, 2)) + v(i, j)
v(UBound(v, 1), j) = v(UBound(v, 1), j) + v(i, j)
Next
v(UBound(v, 1), UBound(v, 2)) = v(UBound(v, 1), UBound(v, 2)) + v(i, UBound(v, 2))
Next

Range("B2:D4").ClearContents
Range("B2:D4").Value = v


End Sub

このような感じでしょうか。

QReDim

下記のコードを詳しく教えて
   
x2 = Range("C3:E5").Value

ReDim ans2(1 To 1, 1 To UBound(x2)) ←この部分の意味

    For i = LBound(x2, 2) To UBound(x2, 2)

      For j = LBound(x2) To UBound(x2)

       この部分の意味 → ans2(1, i) = ans2(1, i) + x2(j, i)

      Next j

    Next i

Aベストアンサー

全体として以下の様な動作をしています。
ans2(1,1) = Range("C3")~Range("C5")の合計を代入
ans2(1,2) = Range("D3")~Range("D5")の合計を代入
ans2(1,3) = Range("E3")~Range("E5")の合計を代入


> x2 = Range("C3:E5").Value

x2は、要素が行方向1~3、列方向1~3の二次元配列になります。
 x2(1,1)がC3セルの値
 x2(1,2)はD3セルの値
 …
 X2(3,3)がE5セルの値



> ReDim ans2(1 To 1, 1 To UBound(x2))

各列の合計を代入するans2は要素が行方向1~1,列方向が1~3の二次元配列の構成が必要となります。
その割り当てを行っています。



そして以下で各列の合計を計算しています。
> For i = LBound(x2, 2) To UBound(x2, 2)   '列方向の要素変化(1~3/C列~E列)
>   For j = LBound(x2) To UBound(x2)    '行方向の要素変化(1~3/3行~5行)
>     ans2(1, i) = ans2(1, i) + x2(j, i) '各列ごとに行の値を足しこむ
>   Next j
> Next i



試しに
 Range("A1:C1").Value = ans2
とすれば対応するセルに計算結果が表示されます。

全体として以下の様な動作をしています。
ans2(1,1) = Range("C3")~Range("C5")の合計を代入
ans2(1,2) = Range("D3")~Range("D5")の合計を代入
ans2(1,3) = Range("E3")~Range("E5")の合計を代入


> x2 = Range("C3:E5").Value

x2は、要素が行方向1~3、列方向1~3の二次元配列になります。
 x2(1,1)がC3セルの値
 x2(1,2)はD3セルの値
 …
 X2(3,3)がE5セルの値



> ReDim ans2(1 To 1, 1 To UBound(x2))

各列の合計を代入するans2は要素が行方向1~1,列方向が1~3の二次元配列の構成が必要となります...続きを読む

Qエクセルにて貼り付けができません。VBの影響と思うのですが行き詰っています。

カレンダーコントロールを使用して、セルに日付を入力するようにしてみました。
参考にしたのはこちらです。
https://oshiete.goo.ne.jp/qa/8446147.html

これをアレンジして、B1からB4の4つのセルに日付を入力させるようにしました。
この4つのセルを選択したとき意外は、カレンダーは表示されないようになっています。

そうしましましたところ、セルのコピーをした際に、貼り付けがグレーアウトでできなくなってしまいました。
セルのコピーはできて点滅反応するのですが、貼り付け先のセルを選択すると貼り付けがグレーアウトしてしまいます。これはキーボード操作のショートカットでもツールバーから下がってでも、マウスで右クリックでもみな同じです。クリップボードから消えてしまうからのような気がします。

どうしても、「セルをコピーして値のみ貼り付け」のマクロの記録をしボタンフォームで実行をさせたいのです。

カレンダーフォームは

Private Sub Calendar1_Click()
ActiveCell.Value = Calendar1.Value
Calendar1.Value = Date
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 Then
UserForm1.Show
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("b1:b4")) Is Nothing Then
Calendar1.Visible = True
Else
Calendar1.Visible = False
End If
End Sub

としましたが、貼り付けができるようにするにはどのように修正したらいいでしょうか?

ちなみに、B1からB4の4つのセル以外を選択してもカレンダーは表示できなくしています。
たぶんこの辺が原因だと思うのですが、この部分は変更したくありません。

カレンダーコントロールを使用して、セルに日付を入力するようにしてみました。
参考にしたのはこちらです。
https://oshiete.goo.ne.jp/qa/8446147.html

これをアレンジして、B1からB4の4つのセルに日付を入力させるようにしました。
この4つのセルを選択したとき意外は、カレンダーは表示されないようになっています。

そうしましましたところ、セルのコピーをした際に、貼り付けがグレーアウトでできなくなってしまいました。
セルのコピーはできて点滅反応するのですが、貼り付け先のセルを選択する...続きを読む

Aベストアンサー

>カレンダーが表示されている時は非表示という事ですが、該当セル以外が非表示という認識であっていますか?

何を確認したいのか意味不明です。文章での説明では理解して頂けないようなので、コードを書き直してみました。こんな感じです。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("b1:b4")) Is Nothing Then
Calendar1.Visible = True
Else
If Calendar1.Visible Then Calendar1.Visible = False
End If
End Sub

>そうする事でペーストする事ができるようになりますか?

分かりません。試してみて下さい。うまくいかなかったらゴメンナサイ。

別件で、ちょっと気になることがあります。
例えば、A1:B1を範囲選択して、カレンダーをクリックするとA1に日付が入ってしまうような気がします。「そんな操作はしない」というのであれば問題は無いのですが・・・。

>カレンダーが表示されている時は非表示という事ですが、該当セル以外が非表示という認識であっていますか?

何を確認したいのか意味不明です。文章での説明では理解して頂けないようなので、コードを書き直してみました。こんな感じです。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("b1:b4")) Is Nothing Then
Calendar1.Visible = True
Else
If Calendar1.Visible Then Calendar1.Visible = False
End If
End Sub

>そうする事でペーストする事ができる...続きを読む

QADOで複数のBookから抽出

ADOで複数のBookから抽出
することは可能でしょう
例えば
With objCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "TEXT;HDR=YES;FMT=Delimited"
.Open "C:\Users\Desktop\新しいフォルダー (4)"
End With

With objCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0"
.Open "C:\Users\Desktop\Test_1.xlsx"
End With

というかんじで

select とかで必要なデータをとりだす

Aベストアンサー

趣旨が「1個のクエリで複数のBookから」でなければ、複数のConnectionを使えばいいかと思います。
デスクトップのTest_1.xlsxのSheet1とデスクトップの新しいフォルダー (4)内のtest.csvの最初のレコードのフィールドの値を表示します。

Sub sample()
Dim cnn1 As Object
Dim cnn2 As Object
Dim desktop As String
Dim rs1 As Object
Dim rs2 As Object
Dim i As Integer

Set cnn1 = CreateObject("ADODB.Connection")
Set cnn2 = CreateObject("ADODB.Connection")
desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set rs1 = CreateObject("ADODB.Recordset")
Set rs2 = CreateObject("ADODB.Recordset")

With cnn1
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "TEXT;HDR=YES;FMT=Delimited;CSV"
.Open desktop & "新しいフォルダー (4)"
End With
Dim es1 As Object

With cnn2
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0 xml;HDR=YES"
.Open desktop & "Test_1.xlsx"
End With

rs1.Open "SELECT * FROM [test.csv]", cnn1
MsgBox rs1.Fields.Count
For i = 0 To rs1.Fields.Count - 1
MsgBox rs1(i)
Next

rs2.Open "SELECT * FROM [Sheet1$]", cnn2
MsgBox rs1.Fields.Count
For i = 0 To rs1.Fields.Count - 1
MsgBox rs1(i)
Next

rs1.Close
rs2.Close
cnn1.Close
cnn2.Close
End Sub





複数のデータベースを1つのクエリで処理する方法は知りませんが、このVBAがAccessのVBAか、Accessが使える状況のExcelなどのVBAなら、Accessのデータベースにリンクテーブルとして登録すれば、同一データベース内のテーブルとして処理できると思います。

趣旨が「1個のクエリで複数のBookから」でなければ、複数のConnectionを使えばいいかと思います。
デスクトップのTest_1.xlsxのSheet1とデスクトップの新しいフォルダー (4)内のtest.csvの最初のレコードのフィールドの値を表示します。

Sub sample()
Dim cnn1 As Object
Dim cnn2 As Object
Dim desktop As String
Dim rs1 As Object
Dim rs2 As Object
Dim i As Integer

Set cnn1 = CreateObject("ADODB.Connection")
Set cnn2 = CreateObject("ADODB.Connection")
desktop = CreateObject("WScript.Shell...続きを読む

QVBScriptによるExecuteExcel4Macroの使い方について

VBScriptにおいて、Win32API関数のGetWindowTitleをExcel経由で使用したいと考えております。
そこで、ネットで検索したところ、VBScriptからAPI関数の指定の引数の値を取り出す方法がありました。
https://blogs.yahoo.co.jp/nobuyuki_tsukasa/5364628.html

この情報を基に、最前面画面のウィンドウタイトルを取得する下記サンプルコードを作成して実行したたところ、下段から3行目のところで、下記のエラーが出てしまいます。

コード:
Option Explicit

Dim AppExcel
Dim myHwnd
Dim myFixCaption
Dim myCaption
Dim strMacro
Dim ret

Set AppExcel = CreateObject("Excel.Application")

'最前面のウィンドウのウィンドウハンドルを取得
strMacro = "CALL('user32', 'GetForegroundWindow', 'J'" & ")"
strMacro = Replace(strMacro, "'", """")
myHwnd = AppExcel.ExecuteExcel4Macro(strMacro)

'タイトルの取得
'GetWindowText myHwnd, myFixCaption, Len(myFixCaption)
myFixCaption = Space(255)
strMacro = "CALL('user32', 'GetWindowText', '2JCJ', " & CStr(myHwnd) & ", '" & myFixCaption & "', " & Len(myFixCaption) & ")"
strMacro = Replace(strMacro, "'", """")
myFixCaption = AppExcel.ExecuteExcel4Macro(strMacro) '←ここで下記エラー発生
myCaption = Left(myFixCaption, InStr(myFixCaption, vbNullChar) - 1)

Set AppExcel = Nothing

エラー内容:
Application クラスの ExecuteExcel4Macro プロパティを取得できません。

環境:
OS;Windows10
Excel;Excel2013

どこがまずいのか、教えて下さい。

VBScriptにおいて、Win32API関数のGetWindowTitleをExcel経由で使用したいと考えております。
そこで、ネットで検索したところ、VBScriptからAPI関数の指定の引数の値を取り出す方法がありました。
https://blogs.yahoo.co.jp/nobuyuki_tsukasa/5364628.html

この情報を基に、最前面画面のウィンドウタイトルを取得する下記サンプルコードを作成して実行したたところ、下段から3行目のところで、下記のエラーが出てしまいます。

コード:
Option Explicit

Dim AppExcel
Dim myHwnd
Dim myFixCaption...続きを読む

Aベストアンサー

こんばんは。

引用先のブログは、開発を投げたものてしょうから、こちらに振っても同じになるには違いないでしょう。はっきりとどこがということがわかりませんし、どこを直しても、このままでは通らないです。ExecuteExcel4Macroの中の数式のパラメータに、null文字が使えないのかとも思いました。数式のカッコ閉じる、が認識しないのです。

"CALL('user32', 'GetWindowText', '2JCJ', " & CStr(myHwnd) & ", '" & myFixCaption & "', " & Len(myFixCaption) & ")"

それと、
myFixCaption = Space(255) -> myCaption = Left(myFixCaption, InStr(myFixCaption, vbNullChar) - 1) これでは、整合性が取れませんよね。

myFixCaption は、 String(255, Chr(0)) だとは思うのですが、それを入れてしまうと、こんどは、数式のカッコが閉じなくなってしまいます。

試しに、DynamicWrapper なら、かろうじて取得できました。DynamicWrapper は、イントールというか、最初に、簡単な regsvr32.exe のレジストレーションが必要になってしまいますので、好まれないとは思いますが。

'-----DynamicWrapper ---
'サンプル
Dim objDynaWrap
Dim hWnd
Dim buf1
Dim myCap

Set objDynaWrap = CreateObject("DynamicWrapper")
objDynaWrap.Register "USER32.DLL", "GetForegroundWindow" ,"r=l" , "f=s"
objDynaWrap.Register "USER32.DLL", "GetWindowText", "i=lrl","r=l", "f=s"
buf1 =Space(20)
buf1 =String(20,Chr(0)) '30ではダメでした。
hWnd = objDynaWrap.GetForegroundWindow()

ret =objDynaWrap.GetWindowText( hWnd, buf1, Len(buf1))
myCap = Replace(buf1,Chr(0),"")
'myCap = Left(buf1,InStr(buf1,Chr(0))-1)
WScript.Echo myCap
Set objDynaWrap = Nothing

'----------------------------
かろうじて取れると書いたのは、なんとなく、このプログラムには、その作り方そのものに論理的な矛盾があるような気がしたからです。一番上のアプリのタイトルを取るけれども、これが、単独で動かしたら自分自身(VBSファイル)である可能性が高いし、そうでなく、他のプログラムから行っても、そのためのアクティベートしてしまったアプリになるわけです。なお、"i=lrl" のパラメータは合っているかわかりません。

p.s. Excelのバージョンの2013以降は、私の記憶では、オートメーションとして別起動しませんから、あえてExcelを使おうとしても、本体を使うのと同じになってしまうはずです。完全な独立プログラム・アプリを作るなら、Excelは使わないほうが良いのかもしれませんね。

こんばんは。

引用先のブログは、開発を投げたものてしょうから、こちらに振っても同じになるには違いないでしょう。はっきりとどこがということがわかりませんし、どこを直しても、このままでは通らないです。ExecuteExcel4Macroの中の数式のパラメータに、null文字が使えないのかとも思いました。数式のカッコ閉じる、が認識しないのです。

"CALL('user32', 'GetWindowText', '2JCJ', " & CStr(myHwnd) & ", '" & myFixCaption & "', " & Len(myFixCaption) & ")"

それと、
myFixCaption = Space(255) -> my...続きを読む

QExcel コードでの簡単な2種類のマクロ実行について

マクロ初心者で詰まってしまっています。バージョンは2016です。

コードを利用して二種類のおなじようなマクロを実行したいです。
①1つの範囲内のセルをダブルクリックで2通→1通→ブランク
②(①とは別の)1つの範囲内のセルをダブルクリックで〇→ブランク

2つめのElseIfに対応するIfがないとのエラーが出てしまうのですが、①②をするにはどこを直せばよいのでしょうか。
なお、同様のことを③(別範囲)として行いたいです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Cancel = True
If Intersect(Target, Range("D5:D50")) Is Nothing Then Exit Sub

Select Case Target.Value
Case ""
Target.Value = "2通"
Case "2通"
Target.Value = "1通"
Case "1通"
Target.Value = ""

Cancel = True

ElseIf Not Application.Intersect(Target, Range("E5:E50")) Is Nothing Then Exit Sub

Select Case Target.Value
Case ""
Target.Value = "〇"
Case "〇"
Target.Value = ""

End Select
End Sub

よろしくお願いいたします。

マクロ初心者で詰まってしまっています。バージョンは2016です。

コードを利用して二種類のおなじようなマクロを実行したいです。
①1つの範囲内のセルをダブルクリックで2通→1通→ブランク
②(①とは別の)1つの範囲内のセルをダブルクリックで〇→ブランク

2つめのElseIfに対応するIfがないとのエラーが出てしまうのですが、①②をするにはどこを直せばよいのでしょうか。
なお、同様のことを③(別範囲)として行いたいです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, C...続きを読む

Aベストアンサー

こんばんは。

インデンティング(indenting-行下げ)をきちんとしていないから、エラーが見つからないのでしょうね。縦で揃えるようにして並べ直しますと、間違っていれば、Select --- End, Select, If ---End if が 揃わなくなります。
アドイン・ツールもあるのですが、今、サイトが開かないようです。
Smart Indenter という名前です。

なるべく、オリジナルを生かしています。
'//
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Intersect(Target, Range("D5:E50")) Is Nothing Then Exit Sub
 If Not Intersect(Target, Range("D5:D50")) Is Nothing Then
  Cancel = True
  Select Case Target.Value
   Case ""
    Target.Value = "2通"
   Case "2通"
    Target.Value = "1通"
   Case "1通"
    Target.Value = ""
  End Select
 ElseIf Not Intersect(Target, Range("E5:E50")) Is Nothing Then
  Cancel = True
  Select Case Target.Value
   Case ""
    Target.Value = "〇"
   Case "〇"
    Target.Value = ""
  End Select
 End If
End Sub

こんばんは。

インデンティング(indenting-行下げ)をきちんとしていないから、エラーが見つからないのでしょうね。縦で揃えるようにして並べ直しますと、間違っていれば、Select --- End, Select, If ---End if が 揃わなくなります。
アドイン・ツールもあるのですが、今、サイトが開かないようです。
Smart Indenter という名前です。

なるべく、オリジナルを生かしています。
'//
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Intersect(Target, Range("D5:E50"...続きを読む

Q【VBAマクロ:繰り返し処理に関して】 エクセルVBA初心者です。下記のマクロに関してご指導をお願い

【VBAマクロ:繰り返し処理に関して】
エクセルVBA初心者です。下記のマクロに関してご指導をお願いいたします。

sheet1にデータベースがあります。J列に記載されたコードを、L列にリスト化された特定のコードでソートして新しいブックに抽出するマクロを組みました。

求めていたのは、L2のコードでソートして貼り付けたブック、L3のコードでソートして貼り付けたブック…とL列にリスト化したコードをひとつずつ、順番にソートしたデータが抽出されることでした。しかし、組んだマクロを実行してみると、L2のコードでソートして貼り付けたブック、L2〜L3のコードでソートして貼り付けたブック、L2〜L4のコードでソートして貼り付けたブック…とn+1ずつ抽出対象が増えてソートされるようになりました。原因はソートする対象が行になっているためだとは思うのですが、修正が上手くいかず困っております。是非とも助けて頂きたいです。よろしくお願いいたします。

下記は、現時点でのマクロです。
こちらに手を加えて、求むべき姿にして頂けるとありがたいです。

Option Explicit
'
Sub Macro1()
'
Dim I As Worksheet
Dim Row As Long
Dim IRange As Range
Dim FileName As String
'
Set I = ThisWorkbook.ActiveSheet
Row = [J1].End(xlDown).Row
Set IRange = Range("A1", "J" & Row)
ActiveSheet.AutoFilterMode = False
Workbooks.Add
'
For Row = 2 To I.[L1].End(xlDown).Row
FileName = I.Cells(Row, "L")
IRange.AutoFilter 10, FileName
IRange.Copy [A1]
ActiveWorkbook.SaveAs FileName
Next Row
ActiveWorkbook.Close
ActiveSheet.AutoFilterMode = False

End Sub

【VBAマクロ:繰り返し処理に関して】
エクセルVBA初心者です。下記のマクロに関してご指導をお願いいたします。

sheet1にデータベースがあります。J列に記載されたコードを、L列にリスト化された特定のコードでソートして新しいブックに抽出するマクロを組みました。

求めていたのは、L2のコードでソートして貼り付けたブック、L3のコードでソートして貼り付けたブック…とL列にリスト化したコードをひとつずつ、順番にソートしたデータが抽出されることでした。しかし、組んだマクロを実行してみると、L2のコー...続きを読む

Aベストアンサー

IRange.Copy [A1]行の前に以下を追加してください。

ActiveSheet.Cells.Clear


Forループの中で、Workbooks.Addで追加したブックのSheet1にフィルタした結果を張り付けた後、保存する動作をしていますが、
例えば、前回のループで10行のデータを張り付けたとして、今回のループで5行のデータを張り付けたとすると、6~10行目には前回張り付けたデータがそのまま残っていることになります。
ですから、張り付ける前に一旦シートをクリアする必要があります。

QVBA/GetTickCountの49.7日の境目を跨ぐ時の処理

たまたまGetTickCountの49.7日の境目を通過したと思しき値の急変を経験しました。
ログで処理時間を記録する必要があり、GetTickCountを使用していましたが、境目を意識したプログラムになっていません、下記にて修正を加えるつもりです。

『メイン側』
Dim arg_apiS As Long
arg_apiS = GetTickCount
・・・・処理・・・・
Dim arg_apiN As Long
Dim arg_subTime As Long
arg_apiN = GetTickCount
Call ******(arg_apiS, arg_apiN, arg_subTime)
select case arg_subRslt
・・・・・・
『CallSub側』
Sub ******(ByRef arg_apiS As Long,arg_apiN As Long, arg_subTime As Long)
Select Case True
Case arg_apiS < arg_apiN
arg_subRslt = arg_apiN - arg_apiS
Case arg_apiS < arg_apiN
arg_subRslt = (2 ^ 32 - arg_apiS) + arg_apiN
End Select

単純動作は確認OKですが、境目の模擬的発生もできず・・・
境目を跨いだ状態でも、正常に動くのか確認したく質問しました。
よろしくお願いします。

たまたまGetTickCountの49.7日の境目を通過したと思しき値の急変を経験しました。
ログで処理時間を記録する必要があり、GetTickCountを使用していましたが、境目を意識したプログラムになっていません、下記にて修正を加えるつもりです。

『メイン側』
Dim arg_apiS As Long
arg_apiS = GetTickCount
・・・・処理・・・・
Dim arg_apiN As Long
Dim arg_subTime As Long
arg_apiN = GetTickCount
Call ******(arg_apiS, arg_apiN, arg_subTime)
select case arg_subRslt
・・・・・・
『CallSub側...続きを読む

Aベストアンサー

Case arg_apiS < arg_apiNはまずいですね。
arg_apiS = 49.6日
arg_apiN = 49.8日(オーバーフローして0.1日となる)
この場合に意図した動作になりません。

このサブルーチンの中でもう一度GetTickCountで時間を取得します。仮にこの時間をXとしましょう。
S = X - arg_apiS
N = X - arg_apiN
このSとNを比較すれば49.7日の境目の影響を受けません。検証してみましょう。
arg_apiS = 49.6日
arg_apiN = 0.1日(49.8日)
X = 1.0日

S = X - arg_apiS = 1.1日前(-48.7日のアンダーフロー)
N = X - arg_apiN = 0.9日前

比較すればarg_apiSの方が古いと正しく判断できます。

これが基本的なオーバーフロー(49.7日)問題の回避方法です。

QCSVファイルの結合(重複データは削除。出来ればエクセルのマクロで。)

CSVファイルを結合したいのですが、重複しているデータは削除した結果で結合させたいと
思っています。

CSVファイルはカンマ区切りで30列分、5000行ぐらいのデータ量となっています。
(1行目はタイトル行)
結合したときに、30列分のデータが全て同じ場合はひとつだけ残してかぶっているデータは
削除させたいです。

処理のイメージとしては下記が一番やりやすいのかなと思っていますが、VBA初心者なので
お知恵をお借りしたいです。
・結合したいファイルをCドライブ直下にフォルダ作って置いておく。(多くても10ファイルぐらいです)
・それをエクセルのマクロ(VBA)でマクロ実行したら、上記ファイルを読み込んでワークシートにデータをすべて貼り付けて、重複データを削除。
・残ったデータを新規ファイルで保存(同じディレクトリにCSV形式で保存)
※結合させたときにどれくらいのデータ量になるかは把握出来ていません。

Aベストアンサー

以下のマクロを標準モジュールに登録してください。
使用上の注意
Const folder As String = "D:\goo\excel\goo166"・・・CSVファイルのあるフォルダ
Const outfile As String = "結合.csv"・・・出力するCSVファイル名
上記はあなたの環境に合わせて適切に設定してください。
①拡張子がCSVのファイルのみを処理しています。
②同じ内容か否かは、1行の文字が全く同じなら、同じ内容と判断します。
③入力データ件数、出力データ件数に見出し行は含めません。
④全てのファイルに見出し行があるものとします。
⑤2回目に実行する際は、結合.csvを削除してから行ってください。そうしないと、そのファイルも入力ファイル扱いになってしまいます。
------------------------------------------------------------
Option Explicit
Public Sub CSVファイル結合()
Const folder As String = "D:\goo\excel\goo166"
Const outfile As String = "結合.csv"
Dim dicT As Object
Dim in_data_ctr As Long
Dim out_data_ctr As Long
Dim fname As String
Dim file_ctr As Long
Dim header_line As String
Dim fileNo As Long
Dim out_path As String
Dim key As Variant
in_data_ctr = 0
out_data_ctr = 0
file_ctr = 0
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
fname = Dir(folder & "\" & "*.csv", vbNormal)
Do While fname <> ""
file_ctr = file_ctr + 1
Call read_csv(folder & "\" & fname, dicT, in_data_ctr, header_line)
fname = Dir()
Loop
out_path = folder & "\" & outfile
fileNo = FreeFile '空き番号取得
Open out_path For Output As #fileNo
Print #fileNo, header_line
For Each key In dicT
Print #fileNo, key
out_data_ctr = out_data_ctr + 1
Next
Close #fileNo
MsgBox (file_ctr & "件のファイルを処理しました。入力データ件数=" & in_data_ctr & " 出力データ件数=" & out_data_ctr)

End Sub

Private Sub read_csv(ByVal file_path As String, ByVal dicT As Object, ByRef in_ctr As Long, ByRef header As String)
Dim fileNo As Long
Dim text As String
fileNo = FreeFile '空き番号取得
Open file_path For Input As #fileNo
Line Input #fileNo, header '1行目は見出しなのでヘッダー行へ格納
Do Until EOF(fileNo)
Line Input #fileNo, text
in_ctr = in_ctr + 1
If dicT.exists(text) = False Then
dicT(text) = True
End If
Loop
Close #fileNo
End Sub

以下のマクロを標準モジュールに登録してください。
使用上の注意
Const folder As String = "D:\goo\excel\goo166"・・・CSVファイルのあるフォルダ
Const outfile As String = "結合.csv"・・・出力するCSVファイル名
上記はあなたの環境に合わせて適切に設定してください。
①拡張子がCSVのファイルのみを処理しています。
②同じ内容か否かは、1行の文字が全く同じなら、同じ内容と判断します。
③入力データ件数、出力データ件数に見出し行は含めません。
④全てのファイルに見出し行があるものとします。
⑤2回目...続きを読む

QVBAによるデータ処理・加工について

初心者です。
以前、この場で、添付画像のfig1をfig2のように加工するコードを教えていただきました。
加工内容は次のとおりです。
・各idのrecordの平均値を各idの行始めに算出する
・注)各idの行始めはrecordなし
・注)recordには空白セルがある

これを、添付画像のfig3をfig4のように加工するコードに変更したいのです。
加工内容は次のとおりになります。
・各idのrecordの平均値を各idの行始めに算出する
・注)各idの行始めにもrecordあり → 変更点
・注)recordには空白セルがある

ご教授のほどよろしくお願いいたします。
以下に、参考として現在のコードを示しておきます。
Dim id As Long, record As Long
For id = 2 To Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
If Cells(id, "A") <> Cells(id - 1, "A") Then
record = id
Do While Cells(id, "A") = Cells(record, "A")
record = record + 1
Loop
Cells(id, "B") = WorksheetFunction.Sum(Range(Cells(id + 1, "B"), Cells(record - 1, "B"))) / _
WorksheetFunction.Count(Range(Cells(id + 1, "B"), Cells(record - 1, "B")))
Range(Cells(id + 1, "B"), Cells(record - 1, "B")).ClearContents
id = record - 1
End If
Next id

初心者です。
以前、この場で、添付画像のfig1をfig2のように加工するコードを教えていただきました。
加工内容は次のとおりです。
・各idのrecordの平均値を各idの行始めに算出する
・注)各idの行始めはrecordなし
・注)recordには空白セルがある

これを、添付画像のfig3をfig4のように加工するコードに変更したいのです。
加工内容は次のとおりになります。
・各idのrecordの平均値を各idの行始めに算出する
・注)各idの行始めにもrecordあり → 変更点
・注)recordには空白セルがある

ご教...続きを読む

Aベストアンサー

No.1のお礼に対して。

>示させていただいた現在のコードに少し手を加える感じでは無理でしょうか?

正直何をしているのか良くわかりませんので1から作りました。
何せプロパティを省略するとかは考えられませんし。
この方法(No.1)は10年ほど前には良く回答を見かけたやり方でしたし扱いやすかったので。

どうしても質問文のコードを基準に改良したいのであれば、回答者を指名すべきではないかと思います。
・・・知恵袋にはありますけど、ここのサイトはどうなんでしょうね?
質問文の最初に『○○さんへ』とあればわかるのかな?

憶測でよければ。
.Sum(Range(Cells(id + 1, "B"),
.Count(Range(Cells(id + 1, "B")

の2つの id + 1 を id にするとかかな?


人気Q&Aランキング