I want my code to be cleaner. I am using thousands of files that are always in the same order and can't change the order of the columns in these files.
Here is the messy part of my code:
'...
ActiveSheet.ChartObjects("Graph 1").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$L$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$L$24:$L$4523"
ActiveSheet.ChartObjects("Graph 2").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$K$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$K$24:$K$4523"
ActiveSheet.ChartObjects("Graph 3").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$E$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$E$24:$E$4523"
ActiveSheet.ChartObjects("Graph 4").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$B$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$B$24:$B$4523"
ActiveSheet.ChartObjects("Graph 5").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$U$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$U$24:$U$4523"
ActiveSheet.ChartObjects("Graph 6").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$AB$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$AB$24:$AB$4523"
ActiveSheet.ChartObjects("Graph 7").Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$I$23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'!$I$24:$I$4523"
'...
I can't use a for-loop since the values associated to the graphs are not in order (i.e. Graph 1 values are not in A, Graph 2 values are not in B). I worked with Python in the past and used dictionaries, but I don't know how to do it with VBA.
I tried:
Dim Graph As Variant
Dim StringGraph As String
StringGraph = CStr(Graph)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.Add "1", "L"
dic.Add "2", "K"
dic.Add "3", "E"
dic.Add "4", "B"
dic.Add "5", "U"
dic.Add "6", "AB"
dic.Add "7", "I"
For Each Graph In dic.Keys
ActiveSheet.ChartObjects("Graph" & StringGraph).Activate
ActiveChart.FullSeriesCollection(1).Name = "='BL-remove'!$ & dict(Graph) & $23"
ActiveChart.FullSeriesCollection(1).XValues = "='BL-remove'!$A$24:$A$4523"
ActiveChart.FullSeriesCollection(1).Values = "='BL-remove'! _
dict(Graph) & $24: $ dict(Graph)& $4523"
Next Graph
I know that I'm close the the answer, but maybe there is a better way.
Try something like this:
Dim Graph As Variant
Dim dic As Object, col As String
Set dic = CreateObject("Scripting.Dictionary")
dic.Add "1", "L"
dic.Add "2", "K"
dic.Add "3", "E"
dic.Add "4", "B"
dic.Add "5", "U"
dic.Add "6", "AB"
dic.Add "7", "I"
For Each Graph In dic.Keys
col = dic(Graph)
With ActiveSheet.ChartObjects("Graph" & Graph).Chart.FullSeriesCollection(1)
.Name = "='BL-remove'!$" & col & "$23"
.XValues = "='BL-remove'!$A$24:$A$4523"
.Values = "='BL-remove'!" & col & "$24:$" & col & "$4523"
End With
Next Graph
Related
Please see the bold code below. The debugger says that it is what's causing the 424 "Object Required" error. Any insight/help on this would be greatly appreciated.
Sub GraywolfPlanful()
Dim sForecastFile, sUploadFile, sTab As String
Dim i As Integer
Application.ScreenUpdating = False
sForecastFile = GraywolfWorkbook.Name
Workbooks.Add
sUploadFile = GraywolfWorkbook.Name
Range("A1") = "Company"
Range("B1") = "Department"
Range("C1") = "Location"
Range("D1") = "Segment"
Range("E1") = "Account"
Range("F1") = "Year"
Range("G1") = "Month"
Range("H1") = "Amount"
Range("A2").Select
Windows(sForecastFile).Activate
sTab = Format(Sheets("00_No Department").Range("C1"), "yyyy-mm mmm") & "Project Forecast"
For i = 4 To Sheets.Count
Sheets(i).Select
Range("F6").Select
Do Until (Range("C") = "End" And Range("D") = "Subtotal Other G&A")
If Range("Z" & ActiveCell.Row) <> "" Then
Range("Z" & ActiveCell.Row, "AD" & ActiveCell.Row).Copy
Windows(sUploadFile).Activate
Range(ActiveCell, ActiveCell.Offset(12, 0)).PasteSpecial xlPasteValues
Range("B" & ActiveCell.Row, "B" & ActiveCell.Row + 12) = "Test"
Windows(sCurrentFile).Activate
End If
Loop
Next i
Windows(sUploadFile).Activate
GraywolfWorkbook.SaveAs CurDir & "\Test File Graywolf"
Application.ScreenUpdating = True
End Sub
Similar to in this question https://stackoverflow.com/questions/ask/advice?. I would like to copy and paste values but am receiving a Run-Time Error 438: Object does not support this property or method. Unfortunately I am not doing my copy and paste in the same way as this other person so the answers do not apply to me
Sub precipitation()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim directory As String, fileName As String
directory = "C:\Working-Directory\Precipdata\"
fileName = Dir(directory & "*.csv")
Do While fileName <> ""
sheetName = Left(fileName, Len(fileName) - 4)
Workbooks.Open (directory & fileName)
Workbooks(fileName).Activate
If Range("B1").Value = "GJOA HAVEN A" Then
col = "B"
End If
If Range("B1").Value = "TALOYOAK A" Then
col = "E"
End If
If Range("B1").Value = "GJOA HAVEN CLIMATE" Then
col = "H"
End If
If Range("B1").Value = "HAT ISLAND" Then
col = "K"
End If
If Range("B1").Value = "BACK RIVER (AUT)" Then
col = "N"
End If
yr = Range("B27").Value
lngth = (Range("B27").End(xlDown).Row)
Workbooks("Macroforprecip.xlsm").Activate
Set rw = ActiveSheet.Cells.Find(what:=DateValue("01/01/" & yr))
r = rw.Row
Workbooks(fileName).Worksheet(sheetName).Range("P27", "P" & lngth).Copy Workbooks("Macroforprecip.xlsm").Worksheets("Sheet1").Range(col & r)
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
My error comes on the Workbooks(fileName).Range("P27", "P" & lngth).Copy _
Workbooks("Macroforprecip.xlsm").Range(col & r) line
Thank you
replace:
Workbooks(fileName).Worksheet(sheetName).Range("P27", "P" & lngth).Copy Workbooks("Macroforprecip.xlsm").Worksheets("Sheet1").Range(col & r)
with:
Workbooks(fileName).Activate
Workbooks(fileName).Worksheet(sheetName).Range("P27", "P" & lngth).Select
Selection.Copy
Workbooks("Macroforprecip.xlsm").Activate
worksheets("Sheet1").Activate
Range(col & r).Select
ActiveSheet.Paste
I need to create charts from CSV-files. This happens every day, for quite a few tables, so I automated it.
When the CSV files are created, they're stored in the folder from that day.
When I open my VBA script it'll read all the CSV files in that folder, and paste all the tables (each on a new sheet, obviously) together in a new workbook.
With NewBook
Set sv = .Sheets.Add(After:=.Sheets(i))
sv.Name = SvName
< Add CSV-files to just created sheet >
With sv
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
Debug.Print SvName & ":" & vbTab & "Cells(" & LastRow; ", " & LastColumn & ")"
End With
Set svChart = .Sheets.Add(After:=.Sheets(SvName))
svChart.Name = SvName & " Chart"
With svChart
.Shapes.AddChart.Name = SvName & "-cht"
With .Shapes(SvName & "-cht")
.Left = Range("A1").Left
.Top = Range("A1").Top
.Width = Range("A1:AC56").Width
.Height = Range("A1:AC56").Height
End With
End With
End With
The code above works fine, but is only drawing the parent of the chart. all options i found which supposed to make it a line chart, for example
ActiveChart.ChartType = xlLine
and for the range
ActiveChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
result in an error like
"With not set"
or
"This option is not available for this object"
You need to reference the chart that you create with AddChart :
With your code :
Dim oChart As Chart
Set oChart = .Shapes.AddChart
oChart.Name = SvName & "-cht"
oChart.ChartType = xlLine
oChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
With my code (without Shapes) :
Dim oChart As Chart
Set oChart = ActiveWorkbook.Charts.Add
oChart.Name = SvName & "-cht"
oChart.ChartType = xlLine
oChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
##
Here is your full code with the implemantation that I proposed :
Dim oChart As Chart
With NewBook
Set sv = .Sheets.Add(After:=.Sheets(i))
sv.Name = SvName
'< Add CSV-files to just created sheet >
With sv
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
Debug.Print SvName & ":" & vbTab & "Cells(" & LastRow; ", " & LastColumn & ")"
End With
Set svChart = .Sheets.Add(After:=.Sheets(SvName))
svChart.Name = SvName & " Chart"
With svChart
Set oChart = ActiveWorkbook.Charts.Add
'oChart.Select
oChart.Name = SvName & "-cht"
oChart.ChartType = xlLine
oChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
With .Shapes(SvName & "-cht")
.Left = Range("A1").Left
.Top = Range("A1").Top
.Width = Range("A1:AC56").Width
.Height = Range("A1:AC56").Height
End With
End With
End With
Here is what I use when I want to create a Chart in Excel :
Sub Graph()
Dim Gr As Chart, _
Sr As Series, _
Src_Name As String
Src_Name = "Sheet1"
Set Gr = ActiveWorkbook.Charts.Add
With Gr
'----Source Data Definition
.SetSourceData Source:=Range(Sheets(Src_Name).Cells(2, 1), Sheets(Src_Name).Cells(1197, 2)), PlotBy:=xlColumns
'----Graph Type
.ChartType = xlXYScatterSmoothNoMarkers
'----Location/Placement
.Location Where:=xlLocationAsNewSheet, Name:="NewSheetName"
'----Title
.HasTitle = True
.ChartTitle.Characters.Text = "Chart Title"
'----Data Series 1
Set Sr = .SeriesCollection.NewSeries
With Sr
.Values = Range(Sheets(Src_Name).Cells(2, 2), Sheets(Src_Name).Cells(20, 5))
.XValues = Range(Sheets(Src_Name).Cells(2, 1), Sheets(Src_Name).Cells(20, 1))
.AxisGroup = 1
.Name = "MTTF"
End With
'----Data Series 2
Set Sr = .SeriesCollection.NewSeries
With Sr
.Values = Range(Sheets(Src_Name).Cells(2, 2), Sheets(Src_Name).Cells(20, 5))
.XValues = Range(Sheets(Src_Name).Cells(2, 1), Sheets(Src_Name).Cells(20, 1))
.Name = "MTTR"
'----Placing a Serie on Second axis
.AxisGroup = 2
End With
'----Series' formats
'.SeriesCollection(i).Delete
'----For a line type chart
'.SeriesCollection(i).Format.Line.Weight = 1
'.SeriesCollection(i).Format.Line.ForeColor.RGB = RGB(int1 as integer, int1 as integer, int3 as integer)
'----For an area type chart
'.SeriesCollection(i).Format.Fill.ForeColor.RGB = RGB(int1 as integer, int1 as integer, int3 as integer)
'----Axis parameters
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Age"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Hours"
.PlotArea.Interior.ColorIndex = 2
.Axes(xlValue).MajorGridlines.Border.LineStyle = xlDot
.ChartArea.Font.Size = 14
.Deselect
'----Legend positioning
With .Legend
.Left = 350
.Top = 75
End With
'----Drawing area positiong
With .PlotArea
.Width = 550
.Height = 350
End With
End With
'----Free memory
Set Gr = Nothing
Set Sr = Nothing
End Sub
I have User form where I have command button and input text box.
I want to copy specified range from one worksheet, then name and paste in another sheet.
My code looks like this, but it is not working.
Private Sub CommandButton1_Click()
Dim i, LastRow
Dim ws As Worksheet
Dim k As Integer
Set ws = Worksheets("Vali")
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow 'find fulfiled rows
If Sheets("Sheet1").Cells(i, "D").Value = 1 Then
Sheets("Sheet1").Range(Cells(i, "B"), Cells(i, "D")).Copy Destination:=Sheets("Vali").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
Dim i As Integer
'Next we use a looping process 'We start the loop from row 2 because our worksheet has headers in row 1
For k = 2 To 100
'Now we define a condition that only if there is data under the headers ItemID, Description,
If Cells(k, "A").Value <> "" And Cells(k, "B").Value <> "" And Cells(k, "C").Value <> "" And Cells(k, "D").Value <> "" And Cells(k, "E").Value = "" Then
Cells(k, "D").Value = Me.txtname.Value
End If
Next
Range("E:E").EntireColumn.AutoFit
Range("B4:D21").ClearContents 'clear content on previos sheet, from where we made copy
ActiveWorkbook.Save
ValiFinish.Hide
End Sub
Not sure what you were trying to do with your test on you second loop, because there was no sheet reference, so I choose, let me know if it wasn't that
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim LastRow As Double
Dim ws As Worksheet
Dim Wv As Worksheet
Dim k As Integer
Dim i As Integer
Dim Ti()
ReDim Ti(0)
Dim StartPaste As Double
Dim EndPaste As Double
Dim PastedRange As String
Set ws = Worksheets("Sheet1")
Set Wv = Worksheets("Vali")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
StartPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
For i = 2 To LastRow
If ws.Cells(i, "D").Value = 1 Then
ws.Range(ws.Cells(i, "A"), ws.Cells(i, "D")).Copy _
Destination:=Wv.Range("A" & Rows.Count).End(xlUp).Offset(1)
Ti(UBound(Ti)) = i
ReDim Preserve Ti(UBound(Ti) + i)
EndPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
'2 options because i'm not sur where you want to add the text :
'First one (write on Vali, I think that's what you are looking to do) :
If Wv.Cells(EndPaste, "A").Value <> "" And Wv.Cells(EndPaste, "B").Value <> "" And Wv.Cells(EndPaste, "C").Value <> "" _
And Wv.Cells(EndPaste, "D").Value <> "" And Wv.Cells(EndPaste, "E").Value = "" Then
Wv.Cells(Wv.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'Second one (write on Sheet1) :
If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value <> "" _
And ws.Cells(i, "D").Value <> "" And ws.Cells(i, "E").Value = "" Then
ws.Cells(ws.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'end of options
End If
Next i
PastedRange = "" & Wv.Name & "!R" & StartPaste & "C1:R" & EndPaste & "C3"
ActiveWorkbook.Names.Add Name:=ValiFinish.TxTNaMe.Value, RefersToR1C1:=PastedRange
'clear content on previous sheet, from where we made copy
For i = LBound(Ti) To UBound(Ti) - 1
ws.Range("$B$" & Ti(i) & ":$D$" & Ti(i)).ClearContents
Next i
Wv.Range("E:E").EntireColumn.AutoFit
Set ws = Nothing
Set Wv = Nothing
ActiveWorkbook.Save
ValiFinish.Hide
Application.ScreenUpdating = True
End Sub
I have excel file with filled two columns. First, includes numbers, second letter. I want to fill third column by letter with condition:
IF the same number has "A" in any cells in second colum THEN fill with the letter A every cells for this number in third column
ELSEIF "B" THEN B in third column...
Priority A>B>C>D
use this
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim Cl As Range, i&
i = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each Cl In ActiveSheet.Range("A1:A" & i)
If Not Dic.exists(Cl.Value & Cl.Offset(, 1).Value) Then
Dic.Add (Cl.Value & Cl.Offset(, 1).Value), Cl.Row
End If
Next
For Each Cl In ActiveSheet.Range("A1:A" & i)
If Dic.exists(Cl.Value & "A") Then
Cl.Offset(, 2).Value = "A"
ElseIf Dic.exists(Cl.Value & "B") Then
Cl.Offset(, 2).Value = "B"
ElseIf Dic.exists(Cl.Value & "C") Then
Cl.Offset(, 2).Value = "C"
ElseIf Dic.exists(Cl.Value & "D") Then
Cl.Offset(, 2).Value = "D"
End If
Next
End Sub
output result is
updated against new requirements
use this
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim Cl As Range, i&, key As Variant
i = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each Cl In ActiveSheet.Range("A1:A" & i)
If Not Dic.exists(Cl.Value & Cl.Offset(, 1).Value) Then
Dic.Add (Cl.Value & Cl.Offset(, 1).Value), Cl.Row
End If
Next
For Each Cl In ActiveSheet.Range("A1:A" & i)
For Each key In Dic
If UCase(key) Like Cl.Value & "*A*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
If Cl.Offset(, 2).Value = Empty Then
For Each key In Dic
If UCase(key) Like Cl.Value & "*B*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
End If
If Cl.Offset(, 2).Value = Empty Then
For Each key In Dic
If UCase(key) Like Cl.Value & "*C*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
End If
If Cl.Offset(, 2).Value = Empty Then
For Each key In Dic
If UCase(key) Like Cl.Value & "*D*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
End If
Next
End Sub
output result
If you can use formula instead of VBA following formula would do the job:
=IF(COUNTIFS(A:A,A2,B:B,"A")>0,"A",IF(COUNTIFS(A:A,A2,B:B,"B")>0,"B",IF(COUNTIFS(A:A,A2,B:B,"C")>0,"C","D")))
in this formula COUNTIF function is combining 2 criterias and counting if these criterias meet or not, then IF functions are inputting related letter to the cell.