Excel - VBA -- Loop through worksheets not working

Question

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

 
Range("a2:d11").Copy

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

 
Next x

' (inserts a column and calls it substation)

Range("d:d").EntireColumn.Insert

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

Answer 1

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."

Answer 2

(Removed)