I have two sets of data within my sheet - the first is 1 row per machine, the second is 13 rows per machine. From a drop down box the user will select values from 1, 2, 3, 4, 5, 10, 15, 20, 25, 30 which correspond to the number of machines.
When a value is selected the corresponding rows within the two data sets need to be hidden. For example, if the user selects 5, only the rows for machine 1 to 5 will show.
I have the following code so far, but wondering if there is a simplified way of doing this as I haven't yet added in the individual values (1-5), also how do I have this run when the value is select from the drop down list?
Sub HideRows()
If Range("F19") = "10" Then
Rows("31:60").EntireRow.Hidden = False
Rows("84:473").EntireRow.Hidden = False
Rows("41:60").EntireRow.Hidden = True
Rows("214:473").EntireRow.Hidden = True
ElseIf Range("F19") = "15" Then
Rows("31:60").EntireRow.Hidden = False
Rows("84:473").EntireRow.Hidden = False
Rows("46:60").EntireRow.Hidden = True
Rows("279:473").EntireRow.Hidden = True
ElseIf Range("f19") = "20" Then
Rows("31:60").EntireRow.Hidden = False
Rows("84:473").EntireRow.Hidden = False
Rows("51:60").EntireRow.Hidden = True
Rows("344:473").EntireRow.Hidden = True
ElseIf Range("f19") = "25" Then
Rows("31:60").EntireRow.Hidden = False
Rows("84:473").EntireRow.Hidden = False
Rows("56:60").EntireRow.Hidden = True
Rows("409:473").EntireRow.Hidden = True
ElseIf Range("f19") = "30" Then
Rows("31:60").EntireRow.Hidden = False
Rows("84:473").EntireRow.Hidden = False
End If
End Sub
Thank you
I'm providing a more generic solution. You need to use WOrksheet_Change in the Sheet's Module
Reference: http://msdn.microsoft.com/en-us/library/office/ff839775(v=office.15).aspx
Private Sub Worksheet_Change(ByVal Target As Range)
Debug.Print Target.Address
If Target.Address = "$A$1" Then 'change the address to the dropdown box cell you have
Debug.Print Target.Value
NumMachineShow = CLng(Target.Value)
Cells.EntireRow.Hidden = False ' reset, unhidden every row first
Rows(31 + NumMachineShow & ":60").EntireRow.Hidden = True ' hide the unwanted 1 row per machine here
Rows(61 + NumMachineShow * 13 & ":473").EntireRow.Hidden = True ' hide the detail, you need to modify the numbers yourself
End If
End Sub
Related
I have a spreadsheet of products, which are in particular fonts and backgrounds. I am trying to create a macro so when I perform the find function (CLTR-F), I can click a macro button which will copy my selection, and paste it into the first available cell in Row N starting with the second row ("N2") and ending with the 12th row ("N12").
I have more data in N, for example in N13 and N14, so I cannot simply count the rows occupied and add one. I want to make this code work so this process exits once the first cell has been pasted into. Currently my code simply pastes the selected cell into both N2 and N3. The goal is that once the value is pasted, the process ends. But if the value is not pasted, it will go onto the next available cell and paste, and end, and so on if the cells are occupied until it is pasted in the first empty cell. Below is what I have, and so far it pastes into both N2 and N3, (If N2 is not occupied.)
Sub CopyPasteFirstEmptyCell()
'Copy the selection
Selection.Copy
'Test for N2
If IsEmpty(Range("N2")) = True Then
Selection.Copy Range("N2")
End If
'Test for N3
If IsEmpty(Range("N2")) = True Then
Selection.Copy Range("N3")
'Test For N4-N12 etc. etc.
End Sub
Thank you so kindly for listening. I have looked at relevant threads and have not found a sufficient answer of yet, and I apologize if that answer already exists openly.
I created variables and added them to a final variable to decide the range.
Sub Copy()
'Copy the selection
Selection.Copy
'Create variables
Dim intN2 As Integer
Dim intN3 As Integer
Dim intN4 As Integer
Dim intN5 As Integer
Dim intN6 As Integer
Dim intN7 As Integer
Dim intN8 As Integer
Dim intN9 As Integer
Dim intN10 As Integer
Dim intN11 As Integer
Dim intN12 As Integer
Dim finalint As Integer
'Create If Then statements to increaes finalint
'For N2
If IsEmpty(Range("N2")) = True Then
intN2 = 0
ElseIf IsEmpty(Range("N2")) = False Then
intN2 = 1
End If
'For N3
If IsEmpty(Range("N3")) = True Then
intN3 = 0
ElseIf IsEmpty(Range("N3")) = False Then
intN3 = 1
End If
'For N4
If IsEmpty(Range("N4")) = True Then
intN4 = 0
ElseIf IsEmpty(Range("N4")) = False Then
intN4 = 1
End If
'For N5
If IsEmpty(Range("N5")) = True Then
intN5 = 0
ElseIf IsEmpty(Range("N5")) = False Then
intN5 = 1
End If
'For N6
If IsEmpty(Range("N6")) = True Then
intN6 = 0
ElseIf IsEmpty(Range("N6")) = False Then
intN6 = 1
End If
'For N7
If IsEmpty(Range("N7")) = True Then
intN7 = 0
ElseIf IsEmpty(Range("N7")) = False Then
intN7 = 1
End If
'For N8
If IsEmpty(Range("N8")) = True Then
intN8 = 0
ElseIf IsEmpty(Range("N8")) = False Then
intN8 = 1
End If
'For N9
If IsEmpty(Range("N9")) = True Then
intN9 = 0
ElseIf IsEmpty(Range("N9")) = False Then
intN9 = 1
End If
'For N10
If IsEmpty(Range("N10")) = True Then
intN10 = 0
ElseIf IsEmpty(Range("N10")) = False Then
intN10 = 1
End If
'For N11
If IsEmpty(Range("N11")) = True Then
intN11 = 0
ElseIf IsEmpty(Range("N11")) = False Then
intN11 = 1
End If
'For N12
If IsEmpty(Range("N12")) = True Then
intN12 = 0
ElseIf IsEmpty(Range("N12")) = False Then
intN12 = 1
End If
'Make finalint the total of all other integers
finalint = intN2 + intN3 + intN4 + intN5 + intN6 + intN7 + intN8 + intN9 + intN10 + intN11 + intN12
'Place selection depending on amount of finalint
If finalint = 0 Then
Selection.Copy Range("N2")
ElseIf finalint = 1 Then
Selection.Copy Range("N3")
ElseIf finalint = 2 Then
Selection.Copy Range("N4")
ElseIf finalint = 3 Then
Selection.Copy Range("N5")
ElseIf finalint = 4 Then
Selection.Copy Range("N6")
ElseIf finalint = 5 Then
Selection.Copy Range("N7")
ElseIf finalint = 6 Then
Selection.Copy Range("N8")
ElseIf finalint = 7 Then
Selection.Copy Range("N9")
ElseIf finalint = 8 Then
Selection.Copy Range("N10")
ElseIf finalint = 9 Then
Selection.Copy Range("N11")
ElseIf finalint = 10 Then
Selection.Copy Range("N12")
End If
End Sub
I have written the following Macro.
Sub createFormFields()
' Declare Variables
Dim thisFile As String
Dim thisFileDirectory As String
Dim thisFilePath As String
Dim formFieldsFile As String
Dim formFieldsFilePath As String
Dim customer As String
Dim newFileName As String
Dim fileVersion As String
Dim fileExtension As String
Dim filePath As String
Dim currentAsTime As String
Dim formFieldsWorkbook As Workbook
Dim formFieldsSheet As Object
Dim page As String
Dim questionText As String
Dim questionType As String
Dim questionId As String
Dim topic1 As String
Dim topic2 As String
Dim notes As String
Dim dateAdded As String
Dim questions As Collection
Dim oQuestion As New cQuestion
' Activate First Question from YAML_Script_Creator file
Range("A27").Activate
' Set questions collection as a new collection
Set questions = New Collection
' Begin to Populate oQuestion Objects
Do
If IsEmpty(ActiveCell) Then
Exit Do
Else
' Ensure that variables do not carry over from previous question
page = ""
questionText = ""
questionType = ""
questionId = ""
topic1 = ""
topic2 = ""
notes = ""
dateAdded = ""
' Begin setting variables
DoEvents
' Check if page cell is empty
If IsEmpty(ActiveCell.Offset(0, 24)) Then
page = ""
Else
page = ActiveCell.Offset(0, 24).Value
End If
' Set variables
questionText = ActiveCell.Offset(0, 2).Value
questionType = ActiveCell.Offset(0, 0).Value
questionId = ActiveCell.Offset(0, 1).Value
topic1 = ActiveCell.Offset(0, 18).Value
topic2 = ActiveCell.Offset(0, 20).Value
notes = ActiveCell.Offset(0, 25).Value
dateAdded = ActiveCell.Offset(0, 23).Value
' Set values to oQuestion Object from variables
oQuestion.page = page
oQuestion.questionText = questionText
oQuestion.questionType = questionType
oQuestion.questionId = questionId
oQuestion.topic1 = topic1
oQuestion.topic2 = topic2
oQuestion.notes = notes
oQuestion.dateAdded = dateAdded
' Add oQuestion Object to questions Collection
questions.Add oQuestion
' Move down to the next question
ActiveCell.Offset(1, 0).Activate
End If
Loop
' Save Pertenate Data for new Form Fields File from YAML_Script_Creator file
customer = Range("B3").Value
newFileName = Range("F18").Value
fileVersion = Range("F19").Value
fileExtension = Range("F20").Value
filePath = Range("F21").Value
formFieldsFile = customer & newFileName & fileVersion & fileExtension
formFieldsFilePath = filePath & formFieldsFile
Debug.Print formFieldsFilePath
' If file already exists, delete it
If Dir(formFieldsFilePath) <> "" Then
Kill (formFieldsFilePath)
End If
' Create new form fields file
Set formFieldsWorkbook = Workbooks.Add
' Set Active Sheet
Set formFieldsSheet = formFieldsWorkbook.ActiveSheet
' Get current time and format it
currentAsTime = Format(Now(), "yyyy-MM-dd hh:mm:ss")
' Format new sheet
formFieldsSheet.Range("A1") = "Customer:"
formFieldsSheet.Range("B1") = customer
formFieldsSheet.Range("D1") = "Current as of:"
formFieldsSheet.Range("E1") = currentAsTime
formFieldsSheet.Range("A3") = "Page"
formFieldsSheet.Range("B3") = "Question Text"
formFieldsSheet.Range("C3") = "Question Type"
formFieldsSheet.Range("D3") = "Question ID"
formFieldsSheet.Range("E3") = "Topic 1"
formFieldsSheet.Range("F3") = "Topic 2"
formFieldsSheet.Range("G3") = "Notes on Question"
formFieldsSheet.Range("H3") = "Date Added"
' Make Font Bold
formFieldsSheet.Range("A1").Font.Bold = True
formFieldsSheet.Range("D1").Font.Bold = True
formFieldsSheet.Range("A3").Font.Bold = True
formFieldsSheet.Range("B3").Font.Bold = True
formFieldsSheet.Range("C3").Font.Bold = True
formFieldsSheet.Range("D3").Font.Bold = True
formFieldsSheet.Range("E3").Font.Bold = True
formFieldsSheet.Range("F3").Font.Bold = True
formFieldsSheet.Range("G3").Font.Bold = True
formFieldsSheet.Range("H3").Font.Bold = True
' Make Bottom Border Thick
formFieldsSheet.Range("A3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("B3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("C3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("D3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("E3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("F3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("G3").Borders(xlEdgeBottom).Weight = xlThick
formFieldsSheet.Range("H3").Borders(xlEdgeBottom).Weight = xlThick
' Set Cell Alignments
formFieldsSheet.Range("D1").HorizontalAlignment = xlRight
' Set Column Widths
formFieldsSheet.Range("A1").ColumnWidth = 15.83
formFieldsSheet.Range("B1").ColumnWidth = 36.67
formFieldsSheet.Range("C1").ColumnWidth = 24.17
formFieldsSheet.Range("D1").ColumnWidth = 25
formFieldsSheet.Range("E1").ColumnWidth = 20
formFieldsSheet.Range("F1").ColumnWidth = 20
formFieldsSheet.Range("G1").ColumnWidth = 49.17
formFieldsSheet.Range("H1").ColumnWidth = 15.83
' Activate cell to being writing data to
formFieldsSheet.Range("A4").Activate
' Loop through objects in questions collection
Dim ques As cQuestion
Debug.Print questions.Count
For Each ques In questions
' Populate Form Fields
ActiveCell = ques.page
ActiveCell.Offset(0, 1) = ques.questionText
ActiveCell.Offset(0, 2) = ques.questionType
ActiveCell.Offset(0, 3) = ques.questionId
ActiveCell.Offset(0, 4) = ques.topic1
ActiveCell.Offset(0, 5) = ques.topic2
ActiveCell.Offset(0, 6) = ques.notes
ActiveCell.Offset(0, 7) = ques.dateAdded
' Activate next row for next question
ActiveCell.Offset(1, 0).Activate
Next ques
' Save and close the workbook
ActiveWorkbook.SaveAs fileName:=formFieldsFilePath
ActiveWorkbook.Close
End Sub
The Macro goes through rows in one Excel sheet, save the data from each column in that row to an object which I have written a class for, add each object to a collection, and then write the data to a new Excel sheet in a new workbook.
However, the problem I am running into is while looping through the collection by each object I keep reading out the same data. The collection has 34 items inside of it, each one being different. When looping through the collection, it appears that it is only reading the last object repeatedly. I know each object is different as I have debugged it and printed out the count of the collection.
Example of data I am reading in:
TextQuestion ques_1234566543 Name null TargetAndBaseline 0 true true true true true true true true true true 0.5 0.2 Identity 1 Income 1 11/29/17 Page1 This is the first question
TextQuestion ques_1234566544 Name null TargetAndBaseline 1 true true true true true true true true true true 0.5 0.2 Identity 2 Income 2 11/30/17 This is the secondquestion
TextQuestion ques_1234566545 Name null TargetAndBaseline 2 true true true true true true true true true true 0.5 0.2 Identity 3 Income 3 12/1/17 This is the third question
TextQuestion ques_1234566546 Name null TargetAndBaseline 3 true true true true true true true true true true 0.5 0.2 Identity 4 Income 4 12/2/17 This is the fourth question
TextQuestion ques_1234566547 Name null TargetAndBaseline 4 true true true true true true true true true true 0.5 0.2 Identity 5 Income 5 12/3/17 This is the fifth question
TextQuestion ques_1234566548 Name null TargetAndBaseline 5 true true true true true true true true true true 0.5 0.2 Identity 6 Income 6 12/4/17 This is the sixth question
TextQuestion ques_1234566549 Name null TargetAndBaseline 6 true true true true true true true true true true 0.5 0.2 Identity 7 Income 7 12/5/17 This is the seventh question
TextQuestion ques_1234566550 Name null TargetAndBaseline 7 true true true true true true true true true true 0.5 0.2 Identity 8 Income 8 12/6/17 This is the eighth question
TextQuestion ques_1234566551 Name null TargetAndBaseline 8 true true true true true true true true true true 0.5 0.2 Identity 9 Income 9 12/7/17 This is the nineth question
TextQuestion ques_1234566552 Name null TargetAndBaseline 9 true true true true true true true true true true 0.5 0.2 Identity 10 Income 10 12/8/17 Page2 This is the tenth question
TextQuestion ques_1234566553 Name null TargetAndBaseline 10 true true true true true true true true true true 0.5 0.2 Identity 11 Income 11 12/9/17 This is the eleventh question
Example of the out put:
Customer: ParkerInc Current as of: 11/30/17 11:24
Page Question Text Question Type Question ID Topic 1 Topic 2 Notes on Question Date Added
Name TextQuestion ques_1234566576 Identity Income This is the first question 1/1/18
Name TextQuestion ques_1234566576 Identity Income This is the second question 1/1/18
Thanks in advance.
The reason that getting the same information for every Object in the Collection is that there is only one Object in the Collection with multiple references to it. When you store an Object in a Collection or an Array you are not actually storing the Object just a reference to the memory location of the object's instance.
What you need to do is instantiate a new Object during each iteration and then add the reference to the new Object to the Collection.
Do
If IsEmpty(ActiveCell) Then
Exit Do
Else
Set questions = New Collection
Refactored code using arrays:
Sub createFormFields()
'Declare Variables
Dim Questions() As Variant
Dim LastRow As Long
Dim QuestionIndex As Long
Dim i As Long
Dim customer As String, newFileName As String, fileVersion As String
Dim fileExtension As String, filePath As String, formFieldsFile As String
Dim formFieldsFilepath As String, currentAsTime As String
Dim formFieldsWorkbook As Workbook, formFieldsSheet As Worksheet
With ActiveWorkbook.ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Questions(1 To LastRow - 26, 1 To 7)
For i = 27 To LastRow
QuestionIndex = QuestionIndex + 1
Questions(QuestionIndex, 1) = .Cells(i, "C").Value 'Question Text
Questions(QuestionIndex, 2) = .Cells(i, "A").Value 'Question Type
Questions(QuestionIndex, 3) = .Cells(i, "B").Value 'Question ID
Questions(QuestionIndex, 4) = .Cells(i, "S").Value 'Topic 1
Questions(QuestionIndex, 5) = .Cells(i, "U").Value 'Topic 2
Questions(QuestionIndex, 6) = .Cells(i, "Z").Value 'Notes
Questions(QuestionIndex, 7) = .Cells(i, "X").Value 'Date Added
Next i
End With
' Save Pertenate Data for new Form Fields File from YAML_Script_Creator file
customer = Range("B3").Value
newFileName = Range("F18").Value
fileVersion = Range("F19").Value
fileExtension = Range("F20").Value
If Left(fileExtension, 1) <> "." Then fileExtension = "." & fileExtension
filePath = Range("F21").Value
If Right(filePath, 1) <> "\" Then filePath = filePath & "\"
formFieldsFile = customer & newFileName & fileVersion & fileExtension
formFieldsFilepath = filePath & formFieldsFile
Debug.Print formFieldsFilepath
' If file already exists, delete it
If Dir(formFieldsFilepath) <> "" Then
Kill (formFieldsFilepath)
End If
' Create new form fields file
Set formFieldsWorkbook = Workbooks.Add
' Set Active Sheet
Set formFieldsSheet = formFieldsWorkbook.ActiveSheet
' Get current time and format it
currentAsTime = Format(Now(), "yyyy-MM-dd hh:mm:ss")
' Format new sheet
formFieldsSheet.Range("A1") = "Customer:"
formFieldsSheet.Range("B1") = customer
formFieldsSheet.Range("D1") = "Current as of:"
formFieldsSheet.Range("E1") = currentAsTime
formFieldsSheet.Range("A3:H3") = Array("Page", "Question Text", "Question Type", "Question ID", "Topic 1", "Topic 2", "Notes on Question", "Date Added")
' Make Font Bold
formFieldsSheet.Range("A1,D1,A3:H3").Font.Bold = True
' Make Bottom Border Thick
formFieldsSheet.Range("A3:H3").Borders(xlEdgeBottom).Weight = xlThick
' Set Cell Alignments
formFieldsSheet.Range("D1").HorizontalAlignment = xlRight
' Set Column Widths
formFieldsSheet.Range("A1").ColumnWidth = 15.83
formFieldsSheet.Range("B1").ColumnWidth = 36.67
formFieldsSheet.Range("C1").ColumnWidth = 24.17
formFieldsSheet.Range("D1").ColumnWidth = 25
formFieldsSheet.Range("E1").ColumnWidth = 20
formFieldsSheet.Range("F1").ColumnWidth = 20
formFieldsSheet.Range("G1").ColumnWidth = 49.17
formFieldsSheet.Range("H1").ColumnWidth = 15.83
' Activate cell to being writing data to
formFieldsSheet.Range("A4").Resize(UBound(Questions, 1), UBound(Questions, 2)).Value = Questions
formFieldsWorkbook.SaveAs Filename:=formFieldsFilepath
formFieldsWorkbook.Close
End Sub
I am trying to hide columns based on a value from another sheet. I have read several articles and don't feel like this is very difficult but am having some issues. When the value in Sheets("Data").Cells(2, 3) is 1 everything works fine but when I change it to 2,3 or 4 the code somehow highlights the entire spreadsheet and "hides" everything. Makes no sense. Below is one version using If..Then. I tried the same thing with select case and this same issue occurs.
Sub test()
Dim choice As Integer
Sheets("Summary").Select
Range("O:S").Select
Selection.EntireColumn.Hidden = True
choice = CInt(Sheets("Data").Cells(2, 3))
If choice = 1 Then
Range("O:P").Select
Selection.EntireColumn.Hidden = False
ElseIf choice = 2 Then
Range("Q:Q").Select
Selection.EntireColumn.Hidden = False
ElseIf choice = 3 Then
Range("R:R").Select
Selection.EntireColumn.Hidden = False
ElseIf choice = 4 Then
Range("S:S").Select
Selection.EntireColumn.Hidden = False
End If
Sheets("Summary").Cells(1, 1).Select
Try getting rid of selections. This code works for me.
Sub test()
Dim choice As Integer
Sheets("Summary").Activate
range("O:S").EntireColumn.Hidden = True
choice = CInt(Sheets("Data").Cells(2, 3))
If choice = 1 Then
range("O:P").EntireColumn.Hidden = False
ElseIf choice = 2 Then
range("Q:Q").EntireColumn.Hidden = False
ElseIf choice = 3 Then
range("R:R").EntireColumn.Hidden = False
ElseIf choice = 4 Then
range("S:S").EntireColumn.Hidden = False
End If
Sheets("Summary").Cells(1, 1).Select
End Sub
i am writing a code that checks if the row is yellow and if the value of a cell is true, if both are positive, it should return a blank row and uncheck the checkbox list. Otherwise, it should return a yellow row. I have written the following code, but it is not working. I would appreciate your help
Sub desmarcar_antigos()
Dim i As Integer
For i = 130 To 2 Step -1
If Rows(i).EntireRow.Interior.ColorIndex = 6 Then
If Cells(i, 9).Value = "TRUE" Then
Rows(i).EntireRow.Interior.ColorIndex = 0 And Sheets("Planilha").CheckBox1.Value = False
Else
Rows(i).EntireRow.Interior.ColorIndex = 6
End If
End If
Next i
Application.ScreenUpdating = False
End Sub
You can't use And to run two statements in a single line. Change this line:
Rows(i).EntireRow.Interior.ColorIndex = 0 And Sheets("Planilha").CheckBox1.Value = False
To:
Rows(i).EntireRow.Interior.ColorIndex = 0
Sheets("Planilha").CheckBox1.Value = False
If you really want to run two statements on a single line, you can use :. For example:
Rows(i).EntireRow.Interior.ColorIndex = 0 : Sheets("Planilha").CheckBox1.Value = False
but it should be discouraged.
Also, you can check both your conditions using a single If. That way, your Else will run if either fails:
If Rows(i).EntireRow.Interior.ColorIndex = 6 And Cells(i, 9).Value = "TRUE" Then
Rows(i).EntireRow.Interior.ColorIndex = 0
Sheets("Planilha").CheckBox1.Value = False
Else
Rows(i).EntireRow.Interior.ColorIndex = 6
End If
I have a spreadsheet (Sheet3) which collects and sorts data from 25 other sheets. So I don't have a ton of empty rows in Sheet3 I do a VBA loop that first checks to see if a sheet is visible, then it hides and unhides rows based on whether or not they are hidden in the 25 other sheets, like so:
Sheet3.Rows("1791:9290").EntireRow.Hidden = True
For i = 1205 To 1354
If Sheet1.Visible = True Then
If Sheet1.Rows(i).EntireRow.Hidden = False Then
Sheet3.Rows(i + 586).EntireRow.Hidden = False
End If
End If
If Sheet2.Visible = True Then
If Sheet2.Rows(i).EntireRow.Hidden = False Then
Sheet3.Rows(i + 886).EntireRow.Hidden = False
End If
End If
If Sheet4.Visible = True Then
If Sheet4.Rows(i).EntireRow.Hidden = False Then
Sheet3.Rows(i + 1186).EntireRow.Hidden = False
End If
End If
etc...
Due to the type of data I need to pull I unfortunately can't match sheet 3 up with the other 25 sheets row for row. For each row visible in the other 25 sheets, I need Sheet3 to unhide 2 rows.
For example, if SheetX Row 1 is visible, Sheet3 must make rows 1 and 2 visible. If SheetX Row 2 is visible, Sheet 3 must make rows 3 and 4 visible, and so on.
Is there any way to do this outside of me having to change all of the 25 other sheets to double their row count? This is only one part of a huge project and I'd prefer not to add a few thousand more rows if it can be avoided.
Use .Cells and resize to 2 rows in height before applying .EntireRow.
Sheet3.Cells(i + 586, 1).Resize(2, 1).EntireRow.Hidden = False
The Resize property will adjust the height of the range being referenced. The subsequent Range.EntireRow property continues the change in cell reference to include the entire row.
I realized that the only way to do this was to add another integer that would change each time through the loop. So I added Dim J As Integer and set j = 0. I added a line to unhide two rows through each loop and incorporated j into that code. Then I added j = j + 1 to the end of the loop.
So here's how it looks:
Dim j As Integer
j = 0
Sheet3.Rows("1791:9290").EntireRow.Hidden = True
For i = 1205 To 1354
If Sheet1.Visible = True Then
If Sheet1.Rows(i).EntireRow.Hidden = False Then
Sheet3.Rows(i + j + 586).EntireRow.Hidden = False
Sheet3.Rows(i + j + 587).EntireRow.Hidden = False
End If
End If
If Sheet2.Visible = True Then
If Sheet2.Rows(i).EntireRow.Hidden = False Then
Sheet3.Rows(i + j + 886).EntireRow.Hidden = False
Sheet3.Rows(i + j + 887).EntireRow.Hidden = False
End If
End If
If Sheet4.Visible = True Then
If Sheet4.Rows(i).EntireRow.Hidden = False Then
Sheet3.Rows(i + j + 1186).EntireRow.Hidden = False
Sheet3.Rows(i + j + 1187).EntireRow.Hidden = False
End If
End If
etc...
j = j + 1
Next