Excel - VBA -- Loop through worksheets not working

Nina 1 Reputation point

Hello All,

Thank for your help in advance! I am having a hard time with this code . Hopefully you can help me. I am trying to basically transform all the columns after column 7 into rows.

I wrote the code below. If I run it , it works perfectly, but when I try to loop through all the worksheets in the workbook, it does not , it gets stuck on the first worksheet and keeps looping with in. I tried these methods

I attached a picture of the data and a partial picture of the results. Thank you again for your help.

Dim ws workheet

For Each ws In ActiveWorkbook.Worksheets

Call Consolidate1 <- all the code is here

Next ws

The other methodology was

sub CallAll()

Dim Wcount as integer

Dim W as integer

Wcount = Activeworkbook.Worksheetscount (it works)

For W = 1 to Wcount

Call Consolidate1

Next W

End Sub

Either methodology above do not work. Below is the Code under Consolidate 1

Sub Consolidate1()

Dim ws As Worksheet

Dim x As Long

Dim y As Long

Dim q As Long, p As Long


'Application.ScreenUpdating = False

 'MsgBox ("The last used column is: " & lColumn)


'For Each ws In ActiveWorkbook.Worksheets

' ( copy the title 10 times to rows)
For x = 1 To 11

lColumn = ActiveSheet.Cells(5, Columns.Count).End(xlToLeft).Column


ActiveSheet.Range("a" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Next x

' (inserts a column and calls it substation)


Range("D1") = "Substation"


lc = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

'MsgBox lc

lr = ActiveSheet.Cells(Rows.Count, 15).End(xlUp).Row

'MsgBox lr


Range(Cells(1, "A"), Cells(lr, lc)).Copy

Range(Cells(1, "A"), Cells(lr, lc)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

'copy columns and paste data in rows

    For y = 7 To Cells(1, Columns.Count).End(xlToLeft).Column

        If Application.CountA(Cells(1, y).Resize(10)) <> 0 Then

            Cells(2, y).Resize(10).Copy Cells(Rows.Count, 6).End(xlUp)(2)

        End If

    Next y


        '-- Paste Region 


     lastrow = Range("d" & Rows.Count).End(xlUp).Row

    'MsgBox lastrow

    lastcol = Cells(1, Columns.Count).End(xlToLeft).Column

    'MsgBox lastcol


    For p = 6 To lastcol

   	 	For q = 1 To 10


    Cells(1, p).Copy

    Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    		Next q

   		Next p

    'Next ws


'   Application.ScreenUpdating = True


    End Sub

A family of Microsoft spreadsheet software with tools for analyzing, charting, and communicating data.
1,681 questions
Office Development
Office Development
Office: A suite of Microsoft productivity software that supports common business tasks, including word processing, email, presentations, and data management and analysis.Development: The process of researching, productizing, and refining new or existing technologies.
3,709 questions
Excel Management
Excel Management
Excel: A family of Microsoft spreadsheet software with tools for analyzing, charting, and communicating data.Management: The act or process of organizing, handling, directing or controlling something.
1,689 questions
0 comments No comments
{count} votes

2 answers

Sort by: Most helpful
  1. Barry Schwarz 2,511 Reputation points

    Sub Consolidate1 takes no arguments. There is no way for either of your "main" Subs to tell it which worksheet it should work on. As coded, Consolidate1 does all its work on the currently active worksheet.

    Unfortunately, neither one of your calling Subs changes the active worksheet.

    • Your first calling Sub needs a statement like ws.Activate just prior to calling Consolidate1.
    • Your second calling Sub needs a statement like Worksheets(W).Activate just prior to calling Consolidate1.

    Alternately, you could modify Consolidate1 to take a parameter of type Worksheet (e.g., mysheet) and pass the desired worksheet to it, either ws or Worksheets(W), in the calling statement. Then, in Consolidate1, you would replace every reference to "ActiveSheet" with "mysheet."

    0 comments No comments

  2. Viorel 114.5K Reputation points


    0 comments No comments