VBA For Each, Then

Kristenisasuperstar

New Member
Joined
Sep 9, 2016
Messages
3
I am trying to get my code to look at each workbook and if there is a value in the set range to copy data in various cells depending on where the value of data is. I need the Data to go to a summary sheet (already created), but I am getting stuck on how to tell VBA to look at column C in the row the data is found and look in Row 8 of the column the data if found. I hope that is not too confusing.
This is what I have:


Dim cell As Range
Set Rng = Range("D9:BC83")


For Each cell In sht.Name.Rng

If cell.Value <> "" Then myArray(x + 1)=

Next cell
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Code:
sht.Cells(cell.Row, "C")
will represent column C on the current row the code is addressing.
Code:
sht.Cells(8, cell.Column)
will represent row 8 on the current column the code is addressing.
 
Last edited:
Upvote 0
I attached the entire code project I am working on, I am certain I am doing the section of the code (with the super large bolded comment) I am getting a for without a next compile error, and I know that I did not complete the for next loop because I am lost.
Rich (BB code):
Sub Statistics_Create()


Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim x As Long, y As Long
Dim shtName1 As String, shtName2 As String
Dim ContentName As String


'Inputs
  ContentName = "Statistics"


'Optimize Code
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False


'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets("Statistics").Activate
  On Error GoTo 0


  If ActiveSheet.Name = ContentName Then
    myAnswer = MsgBox("A worksheet named [" & ContentName & _
      "] has already been created, would you like to replace it?", vbYesNo)
    
    'Did user select No or Cancel?
      If myAnswer <> vbYes Then GoTo ExitSub
      
    'Delete old Contents Tab
      Worksheets(ContentName).Delete
  End If


'Create New Contents Sheet
  Worksheets.Add Before:=Worksheets(1)


'Set variable to Contents Sheet
  Set Content_sht = ActiveSheet


'Format Contents Sheet
  With Content_sht
    .Name = ContentName
        Columns("A:A").Select
    Selection.NumberFormat = "000-00-0000"
    Columns("B:B").Select
    Selection.NumberFormat = "m/d/yy;@"
    Columns("C:C").Select
    Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    Columns("D:D").Select
    Selection.NumberFormat = "General"
    Columns("E:E").Select
    Selection.NumberFormat = "0.00"
    Columns("F:F").Select
    Selection.NumberFormat = "General"
    Columns("G:G").Select
    Selection.NumberFormat = "General"


     Range("A1").Select
    ActiveCell.FormulaR1C1 = "SID"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "DATE"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "TIME"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "SUBJECT"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "# OF VISITS"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "CAMPUS"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "PROGRAM"
    Range("A1:G1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
    End With
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Arial"
        .Size = 14
        .ColorIndex = xlAutomatic
  
    End With
    Columns("A:G").Select
    Selection.ColumnWidth = 16
    Range("A1:G1").Select
  
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
  
    


'Create Array list with SID Numbers, Dates and Values
  ReDim myArray(1 To Worksheets.Count - 1)
Dim Rng As Range
Dim Cells As Integer
Set Rng = Range("D9:BC83")
If Not Rng Is Nothing Then
  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName Then
  For Each cell In Rng.Cells
  If cell.Value <> "" Then
   myArray(x + 1, 1) = sht.Cells(cell.Row, "C") And myArray(x + 2, 2) = sht.Cells(8, cell.Column) And myArray(x + 2, 3) = sht.Cells(cell.Value) And myArray(x + 2, 4) = sht.Cells("B2") And myArray(x + 2, 6) = sht.Cells("B6") And myArray(x + 2, 7) = sht.Cells("B7")
   
   
      x = x + 1
    
    


  
  End If
  


'Create Statistics
  For x = LBound(myArray) To UBound(myArray)
    Set sht = Worksheets(myArray(x))
    sht.Activate
    
  
With Content_sht
      Range("A1") = Format(SSN, "NNN-NN-NNNN")
       Range("B1") = Format(date_test, "mm/dd/yy")


      
    
    
    ' Column 5: Displays the number of visits using a countif function
    
    .Cells(x + 2, 5).FormulaR1C1 = "=COUNTIF(C[-4],RC[-4])"
   
   '   Find the last filled row in column E


Range("D3:E3").AutoFill Range("D3:E" & Range("E2").End(xlDown).Row)


    End With
  
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit


  'Adjust Zoom and Remove Gridlines
    ActiveWindow.DisplayGridlines = True
    ActiveWindow.Zoom = 100


ExitSub:
'Optimize Code
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
End Sub
 
Last edited by a moderator:
Upvote 0
I cleaned this up as best I could, but I don't understand the line in red font. Also, when using the With statement, the child objects (not variables) must have a period in front of them to tie them to the parent object, otherwise VBA will default to the active sheet.

Code:
Sub Statistics_Create()
Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim x As Long, y As Long
Dim shtName1 As String, shtName2 As String
Dim ContentName As String
'Inputs
  ContentName = "Statistics"
'Optimize Code
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets("Statistics").Activate
  On Error GoTo 0
    If ActiveSheet.Name = ContentName Then
          myAnswer = MsgBox("A worksheet named [" & ContentName & _
          "] has already been created, would you like to replace it?", vbYesNo)
        'Did user select No or Cancel?
        If myAnswer <> vbYes Then GoTo ExitSub
            'Delete old Contents Tab
            Worksheets(ContentName).Delete
    End If
        'Create New Contents Sheet
        Worksheets.Add Before:=Worksheets(1)
        'Set variable to Contents Sheet
        Set Content_sht = ActiveSheet
        'Format Contents Sheet
        With Content_sht
            .Name = ContentName
            .Columns("A:A").NumberFormat = "000-00-0000"
            .Columns("B:B").NumberFormat = "m/d/yy;@"
            .Columns("C:C").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
            .Columns("D:D").NumberFormat = "General"
            .Columns("E:E").NumberFormat = "0.00"
            .Columns("F:F").NumberFormat = "General"
            .Columns("G:G").NumberFormat = "General"
            .Range("A1") = "SID"
            .Range("B1") = "DATE"
            .Range("C1") = "TIME"
            .Range("D1") = "SUBJECT"
            .Range("E1") = "# OF VISITS"
            .Range("F1") = "CAMPUS"
            .Range("G1") = "PROGRAM"
            With .Range("A1:G1").Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 15773696
            End With
            With .Range("A1:G1").Font
                 .Bold = True
                 .Name = "Arial"
                 .Size = 14
                 .ColorIndex = xlAutomatic
            End With
            .Columns("A:G").ColumnWidth = 16
            With .Range("A1:G1").Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
'Create Array list with SID Numbers, Dates and Values
 ReDim myArray(1 To Worksheets.Count - 1)
 Dim Rng As Range
 Dim Cells As Integer
 Set Rng = Range("D9:BC83")
     If Not Rng Is Nothing Then
         For Each sht In ActiveWorkbook.Worksheets
             If sht.Name <> ContentName Then
                 For Each cell In Rng.Cells
                     If cell.Value <> "" Then
                       [COLOR=#FF0000] myArray(x + 1, 1) = sht.Cells(cell.Row, "C") And myArray(x + 2, 2) = sht.Cells(8, cell.Column) And myArray(x + 2, 3) = sht.Cells(cell.Value) And myArray(x + 2, 4) = sht.Cells("B2") And myArray(x + 2, 6) = sht.Cells("B6") And myArray(x + 2, 7) = sht.Cells("B7")[/COLOR]
                        x = x + 1
                     End If
                     'Create Statistics
                     For x = LBound(myArray) To UBound(myArray)
                          Set sht = Worksheets(myArray(x))
                          sht.Activate
                          With Content_sht
                              .Range("A1") = Format(SSN, "NNN-NN-NNNN")
                              .Range("B1") = Format(date_test, "mm/dd/yy")
                              ' Column 5: Displays the number of visits using a countif function
                              .Cells(x + 2, 5).FormulaR1C1 = "=COUNTIF(C[-4],RC[-4])"
                              'Find the last filled row in column E
                              .Range("D3:E3").AutoFill Range("D3:E" & Range("E2").End(xlDown).Row)
                          End With
                    Next
                Next
             End If
         Next
    End If
 Content_sht.Columns(3).EntireColumn.AutoFit
  'Adjust Zoom and Remove Gridlines
    ActiveWindow.DisplayGridlines = True
    ActiveWindow.Zoom = 100
ExitSub:
'Optimize Code
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,287
Members
452,631
Latest member
a_potato

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top