Looping through sheets help

[apunc1]

Hi,
The following loop works as intended

Sub testloop()

    Dim ws As Worksheet
    
    For Each ws In ActiveWorkbook.Worksheets
         
        
        
        On Error Resume Next 'Will continue if an error results
        ws.Range("A2") = ws.Name
        
         
    Next ws
End Sub

it loops through each spreadsheet in the workbook, putting the name of the sheet in A2.

The loop below DOES NOT work as intended.

 Sub testmove()
 Dim ws As Worksheet
 For Each ws In ActiveWorkbook.Worksheets
   On Error Resume Next 'Will continue if an error results
    Columns("D:E").Select
    Selection.Copy
    Range("F1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("D:E").Select
    Selection.delete
Next ws
End Sub

it loops through the code correctly, but ON THE SAME SHEET, not looping THROUGH the sheets. It just keep coping D and E to F, deleting D and E, over and over on the same sheet.

what is the problem?

thanks.

[Norie]

You are missing worksheet references for Columns, Range etc.

Try this.

Sub testmove()
Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            .Columns("D:E").Copy .Range("F1")

            .Columns("D:E").Delete
            Application.CutCopyMode = False
        End With
    Next ws
End Sub

[apunc1]

Thanks Norie. This appears to be working.
What I'm really trying to do is loop through all worksheets in a workbook, find the words Volume and Revenue in the header row, copy and paste those columns to the column after the last column of data (lastusedcolumn+1) and delete the original columns.

below is my attempt, but it just loops through the columns on one spreadsheet again.

Sub VolumeMove()

    Dim ws As Worksheet
     Dim last_column As Integer
    Dim targetcol As Integer
    
    For Each ws In ActiveWorkbook.Worksheets
         
    
         'last_column = ws.Cells.find("*", [A1], , , xlByColumns, xlPrevious).Column
         With ws
          last_column = ws.Cells(1, .Columns.Count).End(xlToLeft).Column


        On Error Resume Next 'Will continue if an error results
       
         For iloop = 1 To last_column
            If InStr(1, ws.Cells(1, iloop), "Volume", vbTextCompare) <> 0 Then
     Columns(iloop).Select
            Selection.Copy
            End If
    targetcol = last_column + 1
        With ws.Columns(targetcol)
        ws.Columns(targetcol).Select
      Selection.PasteSpecial xlPasteAll
        ws.Cells(1, targetcol).Value = "Total Volume"
       End With
           
     
        
        Next iloop
     End With
    Next ws
End Sub

You are missing worksheet references for Columns, Range etc.

Try this.

Sub testmove()
Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            .Columns("D:E").Copy .Range("F1")

            .Columns("D:E").Delete
            Application.CutCopyMode = False
        End With
    Next ws
End Sub

[apunc1]

ok I can get it to do everything I need except copy the entire column. It just copies the header into the first column after the last column of data. also i can't get it to delete the original "volume" column.

Sub VolumeMove()

    Dim ws As Worksheet
     Dim last_column As Integer
    Dim targetcol As Integer
    Dim curCol As Integer
    
    
    For Each ws In ActiveWorkbook.Worksheets
         
    
         'last_column = ws.Cells.find("*", [A1], , , xlByColumns, xlPrevious).Column
         With ws
          last_column = ws.Cells(1, .Columns.Count).End(xlToLeft).Column


        On Error Resume Next 'Will continue if an error results
       
         For iloop = 1 To last_column
         
           curCol = Column + last_column
            If InStr(1, ws.Cells(1, iloop), "Volume", vbTextCompare) <> 0 Then
            .Columns(curCol).Copy
            End If
    targetcol = last_column + 1
        With ws.Columns(targetcol)
        ws.Columns(targetcol).Select
      Selection.PasteSpecial xlPasteAll
        ws.Cells(1, targetcol).Value = "Total Volume"
        
       End With
            If InStr(1, ws.Cells(1, iloop), "Volume", vbTextCompare) <> 0 Then
            .Columns(curCol).delete xlToLeft
        End If
     
        
        Next iloop
     End With
    Next ws
End Sub

[Norie]

Does this work?

Sub VolumeMove()

Dim ws As Worksheet
Dim last_column As Integer
Dim targetcol As Integer
Dim curCol As Integer


    For Each ws In ActiveWorkbook.Worksheets


        'last_column = ws.Cells.find("*", [A1], , , xlByColumns, xlPrevious).Column
        With ws
            last_column = ws.Cells(1, .Columns.Count).End(xlToLeft).Column

            targetcol = last_column + 1


            For iloop = 1 To last_column

                curCol = Column + last_column
                If InStr(1, ws.Cells(1, iloop), "Volume", vbTextCompare) <> 0 Then

                    .Columns(curCol).Copy .Columns(targetcol)

                    .Cells(1, targetcol).Value = "Total Volume"
                    .Columns(curCol).Delete xlToLeft
                End If


            Next iloop
        End With
    Next ws
End Sub

[apunc1]

Thanks. It works on some of the sheets but not all. Also, it's deleting thewrong column. I want to rename the new Volume column "Total Volume" and remove the old "volume" column.

[Norie]

Is there always a volume column on a worksheet?

Can you attach a sample workbook?

[apunc1]

yes. There are about ten worksheets with silmilar column headings. All Have a Volume and Revenue Column. It's an export from an Access crosstab, so the volume and revenue totals are in the wrong place. I want them at the end of the other colums.

Is there always a volume column on a worksheet?

Can you attach a sample workbook?

[apunc1]

I can't get the file to upload. Sorry

edit: it's also coping and pasting the wrong volume column. I actually don't know what it's pasting!

[apunc1]

The vbscript below works for one sheet only. When I try to loop the sheets, the loop doesn't work so that's why i'm trying to do this in VBA. I was trying to follow the basic structure of the vbscript, since it works, but add the looping sheets.

 Set objExcel = CreateObject("Excel.Application")  
objExcel.Visible = False  'opens in read-write mode
objExcel.DisplayAlerts = 0  

objExcel.Workbooks.Open "H:\SMART\ReportStd\Parrish\GenzymeReveal\" & "Microarray_LabDM_Reveal_" & dtmYesterday & ".xlsx",,False

Set currentWorkSheet = objExcel.ActiveWorkbook.Worksheets("Data")  

usedColumnsCount = currentWorkSheet.UsedRange.Columns.Count  
usedRowsCount = currentWorkSheet.UsedRange.Rows.Count  
top = currentWorksheet.UsedRange.Row  
left = currentWorksheet.UsedRange.Column  

Set Cells = currentWorksheet.Cells  
For row = 0 to (usedRowsCount - 1)  
 For column = 0 to (usedColumnsCount - 1)  
  curRow = row+top  
  curCol = column+left  
  word = Cells(curRow,curCol).Value
  
 if instr(1, word, "Grand") > 0  then
      With currentWorkSheet.Columns(curCol)
		.Copy
	 End With   
	
targetCol = usedColumnsCount + 1 
With currentWorkSheet.Columns(targetCol)
objexcel.Columns(targetCol).Select
objexcel.Selection.PasteSpecial xlPasteAll
objexcel.cells(1,targetCol).Value="Total Volume"
end with
 	End If 
	'delete old total column
	  if instr(1, word, "Grand") > 0  then
      With currentWorkSheet.Columns(curCol)
		.Delete xlToLeft
	    End With 

End If 
  
Next  'next row
Next	'next column

[apunc1]

this code does what i want. I had curCol defined incorrectly, so it was doing weird things. thanks for your help.

Sub VolumeMove()

Dim ws As Worksheet
Dim last_column As Integer
Dim targetcol As Integer
Dim curCol As Integer


    For Each ws In ActiveWorkbook.Worksheets


        'last_column = ws.Cells.find("*", [A1], , , xlByColumns, xlPrevious).Column
        With ws
            last_column = ws.Cells(1, .Columns.Count).End(xlToLeft).Column

            targetcol = last_column + 1


            For iloop = 1 To last_column

                curCol = Column + iloop
                If InStr(1, ws.Cells(1, iloop), "Volume", vbTextCompare) <> 0 Then

                    .Columns(curCol).Copy .Columns(targetcol)

                    .Cells(1, targetcol).Value = "Total Volume"
                    .Columns(curCol).delete xlToLeft
                End If
            Next iloop
           
        End With
        
    Next ws
End Sub