| |
▼横入り さん：
端折っている部分もございますが、だいたい下記の内容が主要です。
ただ不要な部分が多いことや下記内容では伝わらないかもしれませんが、
そのときはご返信ください。
----------------------------------------
ユーザーフォーム 'ユーザーフォーム１の後、下記ユーザーフォームが開く
Sub commandbutton1_click()
Dim folderPath As String
Dim FileNames
Dim CSVname As String
Dim tmpSheet As Worksheet '開くCsvファイル
Dim ActSheet As Worksheet 'コピー先シート
Dim a As Long, e As Long, g As Long
Dim b As Long, f As Long
Dim c As Long
Dim d As Long
Dim h As Long, i As Long, j As Long, k As Long
Dim l As Long, m As Long, n As Long, o As Long
Dim p As Long, q As Long, r As Long, s As Long
Dim t As Long, u As Long
If OptionButton1 = True Then
'ユーザーフォームにあるオプションボタン１つの動作
Unload UserForm1
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
b = sh2.Cells(6, 8).Value
c = sh2.Cells(5, 21).Value
d = sh2.Cells(7, 6).Value
CreateObject("WScript.Shell").CurrentDirectory = "○○"
FileNames = Application.GetOpenFilename("CSV File,*.csv", MultiSelect:=True)
If VarType(FileNames) = vbBoolean Then Exit Sub
Set ActSheet = ActiveSheet
Application.ScreenUpdating = False
e = 1 'コピー列
For a = 1 To UBound(FileNames)
CSVname = Mid$(FileNames(a), InStrRev(FileNames(a), "\") + 1)
ActSheet.Cells(1, e).Value = CSVname
ActSheet.Cells(2, e).Value = "○○"
Set tmpSheet = Workbooks.Open(FileNames(a), Local:=True).Sheets(1)
With tmpSheet
.Cells(c, 1).Resize(b).Copy ActSheet.Cells(3, e)
.Parent.Close False
End With
Set tmpSheet = Nothing
e = e + 4
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
f = 2
For g = 1 To UBound(FileNames)
ActSheet.Cells(2, f).Value = "○○"
Set tmpSheet = Workbooks.Open(FileNames(g), Local:=True).Sheets(1)
With tmpSheet
.Cells(c, 2).Resize(b).Copy ActSheet.Cells(3, f)
.Parent.Close False
End With
Set tmpSheet = Nothing
f = f + 4
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
h = 3
For i = 1 To UBound(FileNames)
ActSheet.Cells(2, h).Value = "○○"
Set tmpSheet = Workbooks.Open(FileNames(i), Local:=True).Sheets(1)
With tmpSheet
.Cells(c, 3).Resize(b).Copy ActSheet.Cells(3, h)
.Parent.Close False
End With
Set tmpSheet = Nothing
h = h + 4
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
End If
列数を取得
Date1
End Sub
-------------------------------------------
モジュール１
-----------------------------------------------------
Sub Date1()
Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")
Dim u As Long, t As Long
Dim h As Long
Dim w As Integer
Dim x As Integer
Dim o As Long, p As Long
Dim r As Single
t = sh2.Cells(4, 2).Value
h = sh2.Cells(6, 8).Value
u = 2
If u <= t * 4 Then
For w = u To 4 * t
If sh1.Cells(3, u).Value = "" Then
Exit For
sh1.Select
Cells.Clear
End If
x = sh1.Cells(65536, u).End(xlUp).Row
sh2.Cells(18, 8).Value = x
If sh1.Cells(3, u).Value <> "" Then
sh1.Cells(2, u + 2).Value = "○○"
End If
For o = 3 To x
sh1.Cells(o, u + 2).FormulaR1C1 = "=RC[-1]/1000+RC[-2]"
Selection.NumberFormatLocal = "G/標準"
Selection.NumberFormatLocal = "0.000_ "
Next o
sh1.Select
Cells(3, u + 2).Resize(x).Select
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.Axes(xlValue).MajorGridlines.Select
With Selection.Border
.ColorIndex = 2
.Weight = xlHairline
.LineStyle = xlContinuous
End With
ActiveChart.Axes(xlCategory).Select
With Selection.Border
.Weight = xlHairline
.LineStyle = xlAutomatic
End With
With Selection
.MajorTickMark = xlInside
.MinorTickMark = xlNone
.TickLabelPosition = xlNone
End With
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.CrossesAt = 1
.TickLabelSpacing = 1
.TickMarkSpacing = 1
.AxisBetweenCategories = True
.ReversePlotOrder = False
End With
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(1).Name = sh1.Cells(2, u + 2).Value
With Selection.Border
.Weight = xlHairline
.LineStyle = xlAutomatic
End With
With Selection.Interior
.ColorIndex = 2 'グラフの領域を白にする
.PatternColorIndex = 1
.Pattern = xlSolid
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = sh1.Cells(1, u - 1).Value
End With
ActiveChart.SeriesCollection(1).Select
With Selection
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
ActiveChart.SeriesCollection(1).Select
With Selection
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
u = u + 4
Next w
Else
MsgBox "値がおかしいです。"
End If
End Sub
---------------------------------------
モジュール２
---------------------------------------
列数
Sub 列数を取得()
Set sh1 = Sheets("sheet1")
Dim 列数 As Integer
Dim t As Long, w As Long
t = 1
For 列数 = t To 256
If sh1.Cells(3, t + 1).Value = "" And sh1.Cells(3, t + 2).Value = "" Then
w = t + 1
Sheet2.Select
Sheet2.Cells(2, 2).Value = w
Exit For
End If
t = t + 1
Next 列数
End Sub
-------------------------
モジュール３
--------------------------------
Sub 最終行数カウント()
Dim e As Long, num As Integer
Set sh2 = Sheets("sheet2")
Set sh1 = Sheets("sheet1")
If sh1.Range("A2:B5").CurrentRegion.Rows.Count = "" Then
Exit Sub
Else
e = sh1.Range("A2:B5").CurrentRegion.Rows.Count
sh2.Cells(17, 8).Value = e
num = sh1.Range("F65536").End(xlUp).Row
sh2.Cells(18, 8).Value = num
End If
End Sub
|
|
新参者2
- 09/3/16(月) 14:42 -
