I want to create a macro that when activated, will hide all columns and rows that don't have a cell formatted to a certain colour. I adapted a similar sub for columns with content only but this is another step extra that my brain can't seem to get around this morning. For reference, this is what I used to hide all columns that did not have content:
Sub HideCols()
Dim LC As Integer, j As Integer
Dim LR As Integer, curCnt As Integer
Dim k As Integer
Dim Data As Variant
Application.ScreenUpdating = False
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
Data = Range(Cells(1, 1), Cells(LR, LC))
For k = 1 To LR
If Rows(k).Hidden = False And Data(k, j) <> "" Then _
curCnt = curCnt + 1
Next k
Columns(j).Hidden = curCnt < 2
Next j
Application.ScreenUpdating = True
End Sub
Here's how to hide all the row and column of a cell that is black. I'm sure you can modify to fit your need.
Sub hide_cell()
Dim Rng As Range
Dim MyCell As Range
Set Rng = Range("A2:d10")
For Each MyCell In Rng
If MyCell.Interior.ColorIndex = 1 Then
MyCell.EntireRow.Hidden = True
MyCell.EntireColumn.Hidden = True
End If
Next MyCell
End Sub
Related
Hi I would like to create the code, where I could copy the values in a certain array and paste only the values of that array to the column in front.
The arrays to be copied are in multiple arrays and should be copied and pasted to a column in front but only if there are numerical values in column A.
This is how the arrays with values (in yellow) look before the copy:
And here is the outcome when they are pasted in the column in front (overwriting the rest):
My code is not working for many reasons and mainly I think there is the problem with my loops. The first loop should indicate that the copy will take place only on the rows where values in column A are numerical.
Sub Cop()
Application.ScreenUpdating = False
Set CopySheet = ThisWorkbook.Sheets("Sheet1")
Const ColStart As Integer = 4 'Table to start copying
Const NewColStart As Integer = 3 'Table to start pasting
Const ColEnd As Integer = 10 'Table ends for copying and pasting
Const ColumnNumeric As Integer = 1 'Column with numbers
Dim TargetRow As Long
Dim i As Long
Dim cell1 As Range
Dim cell2 As Range
TargetRow = 4 'Row where my table an column with numbers starts
With CopySheet
For Each cell1 In Range(.Cells(TargetRow, ColumnNumeric), .Cells(.Rows.Count, ColumnNumeric))
If IsNumeric(cell1) = True Then
'Numeric value found.
For Each cell2 In Range(.Cells(TargetRow,ColStart),.Cells(.Rows.Count, ColEnd))
cell2.Copy
.Range(.Cells(TargetRow, NewColStart), .Cells(.Rows.Count, ColEnd)).PasteSpecial (xlPasteValuesAndNumberFormats)
Application.CutCopyMode = False
Next cell2
TargetRow = TargetRow + 1
Else
Exit Sub
End If
Next cell1
TargetRow = TargetRow + 1
End With
Can anybody give a hand on that? I was trying different loops but I am not sure how to finish them.
This Sub bellow
Iterates through each cell with data in column A (COL_NUMERIC)
If it contains a number (it doesn't contain an error and it's not empty)
Dynamically determines the last column with data on the current row
Copies the row with data (starting in Col D - COL_START) to an array
Clears the data from the row
Pastes the values from the array, one column to the left (it expects COL_START to be > 1)
Option Explicit
Public Sub MoveRowsLeft()
Const COL_NUMERIC = 1
Const ROW_START = 4
Const COL_START = 4
Dim ws As Worksheet, lr As Long, lc As Long
Dim nCol As Range, itm As Range, r As Long, arr As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, COL_NUMERIC).End(xlUp).Row
If lr > ROW_START Then
Application.ScreenUpdating = False
Set nCol = ws.Range(ws.Cells(ROW_START, COL_NUMERIC), ws.Cells(lr, COL_NUMERIC))
For Each itm In nCol
If Not IsError(itm) Then
If IsNumeric(itm) And Len(itm.Value2) > 0 Then
r = itm.Row
lc = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
If lc > COL_NUMERIC Then
arr = ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc))
ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)).ClearContents
ws.Range(ws.Cells(r, COL_START - 1), ws.Cells(r, lc - 1)) = arr
End If
End If
End If
Next
Application.ScreenUpdating = True
End If
End Sub
I have a piece of code I've used to hide columns based off of values being in that column, essentially it looks at all cells in that column underneath a certain row and if there's a value in there it'll keep it showing and if not it'll hide it.
Now I need it to also hide things based off values from a specific row. This is the code:
Sub HideCols()
Dim LC As Integer, j As Integer
Dim LR As Integer, curCnt As Integer
Dim k As Integer
Dim Data As Variant
Application.ScreenUpdating = False
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 6 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
Data = Range(Cells(1, 1), Cells(LR, LC))
For k = 3 To LR
If Rows(k).Hidden = False And Data(k, j) <> "" Then _
curCnt = curCnt + 1
Next k
Columns(j).Hidden = curCnt < 2
Next j
Application.ScreenUpdating = True
End Sub
I tried adding:
Dim i As Long
Dim c As Variant
Dim l As Integer
For i = 6 To j
For Each c In ActiveSheet.Cells(2, i)
If Columns(i).Hidden and c.Value Like "Tri-Annual" Then
ActiveSheet.Columns(i).Hidden = False
Else
ActiveSheet.Columns(i).Hidden = True
End If
Next c
Next i
This was added in following, so the hope was that it would only look at the columns that weren't hidden by the first macro and then hide all columns that don't also have "Tri-Annual" in that column in row 2. It does complete the task, but I have to run it twice. Is there any easier way of doing this?
Try this. I think I have it the right way round.
Sub HideCols()
Dim LC As Long, j As Long
Dim LR As Long, curCnt As Long
Dim k As Long
Dim Data As Variant
Application.ScreenUpdating = False
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 6 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
Data = Range(Cells(1, 1), Cells(LR, LC))
For k = 3 To LR
If Rows(k).Hidden = False And Data(k, j) <> "" Then _
curCnt = curCnt + 1
Next k
Columns(j).Hidden = curCnt < 2 Or Cells(2, j).Value <> "Tri-Annual"
Next j
Application.ScreenUpdating = True
End Sub
I'm trying to import cells from another wb. So if cell in wb1 col H matches cell in wb2 col K then wb1 col k and L = wb2 col C and E in match row. Now there may be several matches so I want it to offset to the next column. m and n for next set, o and p for next, and so on.
This is what I have so far:
Private Sub CommandButton1_Click()
Dim rcell As Range, sValue As String
Dim lcol As Long, cRow As Long
Dim dRange As Range, sCell As Range
Dim LastRow As Integer
Dim CurrentRow As Integer
Set ws1 = ThisWorkbook
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1")
Sheet1LastRow = ThisWorkbook.Sheets("Data").Range("H2:H50000").Value 'Search criteria column
Sheet2LastRow = Workbooks("Workbook2").Worksheets("Sheet1").Range("Q" & Rows.Count).End(xlUp).Row 'Where to look for matches
With Workbooks("Workbook2").Worksheets("Sheet1")
For j = 1 To Sheet1LastRow
For i = 1 To Sheet2LastRow
If ThisWorkbook.Sheets("Data").Range("H").Value = ws2.Cells(i, 11).Value Then
ws2.Cells(i, 11).Value = ThisWorkbook.Sheets("Data").Range("C").Value
ws2.Cells(i, 12).Value = ThisWorkbook.Sheets("Data").Range("E").Value
End If
If InStr(1, ws2.Cells.Value, ws1.Cells.Value) And Trim(ws1.Cells.Value) <> "" Then
rcell.Offset(0, lcol).Value = ws2.Cells.Offset(0, 2).Value
lcol = lcol + 1
End If
Next i
Next j
End With
End Sub
This doesn't work. I basically gave up since I don't know what I'm missing.
I looked for something like this but only found something a Vlookup or Match could do.
You can do it by keeping track of an offset that you shift by two after each match copied. I'll track this in a variable called offs.
Also I suppose that the copying goes from wb2 to wb1 as described in the text, not as "suspected" in the code.
Private Sub CommandButton1_Click()
Dim cel1 As Range, cel2 As Range
For Each cel1 In ThisWorkbook.Sheets("Data").UsedRange.Columns("H").Cells
Dim offs As Long: offs = 3 ' <-- Initial offset, will increase by 2 after each match
For Each cel2 In Workbooks("Workbook2").Worksheets("Sheet1").UsedRange.Columns("K").Cells
If cel1.Value = cel2.Value Then
cel1.offset(, offs).Value = cel2.offset(, -8).Value ' <- wb2(C) to wb1(K)
cel1.offset(, offs + 1).Value = cel2.offset(, -6).Value ' <- wb2(E) to wb1(L)
offs = offs + 2 ' <-- now shift the destination column by 2 for next match
End If
Next
Next
End Sub
I have a piece of VB code in excel to hide columns with less than 2 data entries (header as a minimum) and I need to know how to use this to hide columns whilst ignoring information in filtered out rows:
Sub HideCols()
Dim LC As Integer, j As Integer
Dim cl As Range, rng As Range
Set rng = Range("Table1").SpecialCells(xlCellTypeVisible)
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
Columns(j).Hidden = WorksheetFunction.CountA(Columns(j)) < 2
Next j
Application.ScreenUpdating = True
End Sub
This is what I have, a lot of it makes no sense and needs tidying up but that's only as I've been trying to find my own way to no avail.
Thanks!
I'd go like follows
Option Explicit
Sub HideCols()
Dim cols As Range
Dim iCol As Long
With Range("Table1")
Set cols = .Resize(1, 1).Offset(, .Columns.Count + 1)
For iCol = 1 To .Columns.Count
If Application.WorksheetFunction.Subtotal(103, .Columns(iCol).SpecialCells(xlCellTypeVisible)) < 2 Then Set cols = Union(cols, .Cells(1, iCol))
Next iCol
Set cols = Intersect(.Columns, cols)
If Not cols Is Nothing Then cols.EntireColumn.Hidden = True
End With
End Sub
as a side note, if filtering is done out of Autofilter() method then also header rows are not filtered out. in this case you may want to change the right term of If check to < 3
Check if it's hidden first
Sub HideCols()
Dim LC As Integer, j As Integer
Dim LR As Integer, curCnt as Integer
Dim cl As Range, rng As Range
Dim Data As Variant
Set rng = Range("Table1").SpecialCells(xlCellTypeVisible)
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
' its faster to iterate a variant array than it is Cells
Data = Range( Cells(1, 1), Cells(LR, LC) )
for k = 1 to LR
if Rows(k).Hidden = False and Data(k, j) <> "" Then _
curCnt = curCnt + 1
next k
Columns(j).Hidden = curCnt < 2
Next j
Application.ScreenUpdating = True
End Sub
Here is my problem. I managed to create a macro that looks like this:
Sub Macro1()
Range("G17:G36").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$G$17:$G$36")
ActiveChart.ChartType = xlLine
End Sub
I know this was pretty basic to record but my problem is how to change it and make the range dynamic and conditional. For example when I get to the row 17 I have a value in the cell D17 that is greater than lets say 200 and a value in E17 greater than 100. This should trigger the beginning of my range. So if D17>200 AND E17>100 I need to get G17 as the beginning of the range. As for G36 (the end of the range) the logic is very similar but this time I would test for a condition like this: IF F36<64 THEN get G36 as the end of the range.
The should repeat till the end. For example the last row could be at 28000 so I expect a good few of these charts to be created along the way.
Thanks is advance for your help,
Schroedinger.
This is how it looks now and gives me a run-time error explained in my correspondence with EngJon.
Sub GenerateCharts()
Application.ScreenUpdating = False
'Get the last row
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim endOfRange As Long
Dim wholeRange As Range
Dim i As Long
For i = 1 To LastRow
If Cells(i, 4) > 0.000001 And Cells(i, 5) > 0.00000002 Then
'Determine the end of the range
endOfRange = DetermineRange(i)
Set wholeRange = Range(Cells(i, 7), Cells(endOfRange, 7))
NewChart (wholeRange)
i = endOfRange
End If
Next i
Application.ScreenUpdating = True
End Sub
Function DetermineRange(row As Long) As Long
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim j As Long
For j = row To LastRow
If Cells(j, 6) < -0.0000000018 Then
DetermineRange = j
Exit Function
End If
Next j
DetermineRange = j
End Function
Function NewChart(rng As Range)
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=rng
ActiveChart.ChartType = xlLine
End Function
This is a final solution for me. I hope it helps someone. Big tnx to EngJon and Paagua Grant.
Sub GenerateCharts()
Application.ScreenUpdating = False
Dim StartCell As Long
Dim EndCell As Long
Dim ChartRange As Range
Dim DataEnd As Long
Dim i As Integer
Dim j As Integer
Dim HasStart As Boolean
Dim HasEnd As Boolean
'Sets end of data based on the row you are charting
DataEnd = Cells(Rows.Count, 7).End(xlUp).Row
'Begin loop to find start and end ranges, create charts based on those ranges
For i = 1 To DataEnd
If HasStart Then
If Cells(i, 4).Value < 0 Then
EndCell = i
HasEnd = True
End If
Else 'If there isn't a starting cell yet
If Cells(i, 4).Value > 0.000001 And Cells(i, 5).Value > 0.00000002 Then
StartCell = i
HasStart = True
End If
End If
If HasStart And HasEnd Then
Set ChartRange = ActiveSheet.Range(Cells(StartCell, 7), Cells(EndCell, 7))
ActiveSheet.Shapes.AddChart(xlLine, _
Left:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell, 10)).Left, _
Top:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell, 10)).Top, _
Width:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell, 20)).Width, _
Height:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell + 25, 10)).Height _
).Select
ActiveChart.SetSourceData Source:=ChartRange
HasStart = False
HasEnd = False
End If
Next
Application.ScreenUpdating = True
End Sub
You can use your recorded Macro1 as a Function and call it when you need to create a new Chart:
Function NewChart(rng As Range)
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=rng
ActiveChart.ChartType = xlLine
End Function
You will also need the following function:
Function DetermineRange(row As Long) As Long
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim j As Long
For j = row To LastRow
If Cells(j, 6) < 64 Then
DetermineRange = j
Exit Function
End If
Next j
DetermineRange = j
End Function
You will call it in a Sub that iterates over all rows:
Sub GenerateCharts()
Application.ScreenUpdating = False
'Get the last row
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim endOfRange As Long
Dim wholeRange As Range
Dim i As Long
For i = 1 To LastRow
If Cells(i, 4) > 200 And Cells(i, 5) > 100 Then
'Determine the end of the range
endOfRange = DetermineRange(i)
Set wholeRange = Range(Cells(i, 7), Cells(endOfRange, 7))
NewChart wholeRange
i = endOfRange
End If
Next i
Application.ScreenUpdating = True
End Sub
Copy those three in a module and execute the Sub. Please comment if this did what you needed.
Here's a slightly different option that performs all of the tasks in a single function.
Option Explicit
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim StartCell As Long, EndCell As Long, ChartRange As Range, DataEnd As Long, i As Integer, j As Integer, HasStart As Boolean, HasEnd As Boolean, _
ChartTop As Long, ChartHeight As Long
DataEnd = Cells(Rows.Count, 7).End(xlUp).Row 'Sets end of data based on the row you are charting.
ChartTop = 50
ChartHeight = 100
'Begin loop to find start and end ranges, create charts based on those ranges.
For i = 1 To DataEnd
If HasStart Then
If Cells(i, 6).Value < 64 Then
EndCell = i
HasEnd = True
End If
Else 'If there isn't a starting cell yet.
If Cells(i, 7).Value > 200 And Cells(i, 5).Value > 100 Then
StartCell = i
HasStart = True
End If
End If
If HasStart And HasEnd Then
Set ChartRange = ActiveSheet.Range(Cells(StartCell, 7), Cells(EndCell, 7))
ActiveSheet.Shapes.AddChart(Top:=ChartTop, Height:=ChartHeight).Select
With ActiveChart
.SetSourceData Source:=ChartRange
.ChartType = xlLine
End With
ChartTop = ChartTop + ChartHeight + 15
HasStart = False
HasEnd = False
End If
Next
Application.ScreenUpdating = True
End Sub
This also makes sure that each chart created by the tool does not overlap the previous chart.
For the sake of space and clarity, I am putting my response to your followup questions here.
Assuming standard row heights and column widths, you can set
ChartTop =(StartCell-1)*15
to set the top of the chart to begin at the top of the same row as your data, and within the
ActiveSheet.Shapes.AddChart(Top:=ChartTop, Height:=ChartHeight).Select
you can add
Left:=(X * 48)
where X is one less than the column number that you want the chart to be left-aligned to, e.g. if you want the chart to start at the left edge of Column I, X would be equal to 8. However, as far as I can tell, there is no easy way to adjust these values if your row height/column widths is non-standard, e.g. if you have auto-fit your columns to your data.