excel - Macro - How to iterate over rows & a range of cells - excel

i've got a question.
I've got the names of sheets in my workbook in a sheet named "Summary". I've got some stats in a sheet called "Stats". I wanna loop over the names in summary sheet, select each sheet, then copy the values from B2:M2 from "stats" page, transpose copy it to column D2 in the sheet selected from "Summary" sheet. Then I want to move to next sheet from the list of sheets from "Summary" page, copy B3:M3 & copy as transpose the D2 column in the selected sheet & so forth.
I've managed to get this bit of code for it. It's not compelte. I'm unable to figure out how to increment from B2:M2 to B3:M3 to B4:M4 & so on.
Please can someone help me. I've never written VB code before.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim row_counter As Long, col_counter As Long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
row_counter = 2
col_counter = 2
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
row_counter = row_counter + 1
col_counter = col_counter + 1
Next MyCell
End Sub

See below code (which is your code with the addition of offset).
Offset will let you increment from B2:M2 to B3:M3 asb so on.
I replaced your row and col variable with just x since you only move by row.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim x as long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
x = 0
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Offset(x, 0).Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
x = x + 1
Next MyCell
End Sub
Also you can try this:
Dim MyCell, MyRange as Range
Dim wb as Workbook
Dim ws, wsTemp, wsStat as Worksheet
Dim x as Long
Set wb = Thisworkbook
Set ws = wb.Sheets("Summary")
Set wsStat = wb.Sheets("Stats")
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set MyRange = .Range("A1:A" & lrow)
End With
x = 0
For Each MyCell in MyRange
Set wsTemp = wb.Sheets(MyCell.Value)
wsStat.Range("B2:M2").Offset(x, 0).Copy
wsTemp.Range("D2").PasteSpecial xlPasteAll, , , True
x = x + 1
Set wsTemp = Nothing
Next MyCell
End Sub
Already Tested.
Hope it does what you want to achieve.

Related

Transpose VBA Excel Macro based on condition

I am trying to copy & transpose values from one Sheet to another Sheet based on a condition, only transpose the first 4 lines looping in large range.
From this:
To this :
I've found a transpose macro and adapt it but I couldn't apply the condition.
Sub Test()
Set rng = Range("B5", Range("B5").End(xlDown))
Sheets("Example #2").Range(rng).Value = WorksheetFunction.Transpose()
EndSub
Anyone can guide me? Any help would be greatly appreciated!
Please, test the next code. It uses arrays, works in memory and will be much faster than copying. This can be easier observed on a large range:
Sub CopyTranspose4rows()
Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, arr, arrSl, i As Long
Set sh1 = ActiveSheet 'use here the sheet you need to copy from
Set sh2 = sh1.Next 'use here what sheet you need to paste
lastR = sh1.Range("B" & sh1.rows.count).End(xlUp).row 'last row sh1
arr = sh1.Range("B5:B" & lastR).Value 'put the range in an array for fast iteration
For i = 1 To UBound(arr) Step 4 'iterate from four to four
With Application
'create a slice array
arrSl = .Transpose(.Index(arr, Evaluate("row(" & i & ":" & i + 4 & ")"), 1))
End With
'drop the slice array content in the second sheet
sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1).Resize(1, 4).Value = arrSl
Next i
sh2.Activate 'activate the sheet where pasted
End Sub
#FaneDuru's array solution is more elegant, but here's another alternative. You would need to replace the sheet names and the starting cell numbers.
Sub TestTranspose()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LR1 As Long
Dim x As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
LR1 = sht1.Cells(Rows.Count, 2).End(xlUp).Row
y = 1
For x = 1 To LR Step 4
sht1.Range(sht1.Cells(x, 2), sht1.Cells(x + 3, 2)).Copy
sht2.Cells(y, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
y = y + 1
Next x
End Sub
With this code you can have different number of answers per question.
Sub Tranpose_Questions()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim transRng As Range ' range to transpose
Dim dstRng As Range: Set dstRng = ActiveSheet.Range("C1") ' destination cell
' Value find
fnd = "Question"
Set myRange = ActiveSheet.Range("A1", Range("A1").End(xlDown))
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
' Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo errHandler
End If
Set rng = FoundCell
' Loop
Do Until FoundCell Is Nothing
' Find next cell
Set FoundCell = myRange.FindNext(after:=FoundCell)
Debug.Print rng.Address, FoundCell.Address
' Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then
Set transRng = Range(rng, rng.End(xlDown))
If rng.Offset(1, 0) <> "" Then
transRng.Select: transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End If
Exit Do
End If
' Transpose
Set transRng = rng.Resize(FoundCell.Row - rng.Row, 1)
transRng.Copy
dstRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
' update rng position
Set rng = FoundCell
' update destination range
Set dstRng = dstRng.Offset(1, 0)
Loop
Exit Sub
' Error Handler
errHandler:
MsgBox "No 'Question' found!"
End Sub

Selected range of cells via VBA doesn't work

EDITED
I would like to ask you for help & revision of my VBA code as I am new to VBA.
I have pivot table with 3 columns. Via slicer I choose the items I want to add in new data table, each item must be added 3 times - therefore in the code I used loop 3 times.
The VBA works perfectly when 2 or more items are chosen.
However, when only single item is selected, the VBA crashes because the "selected copied range" does not have the same size as "pasted range" size. Basically, it selects all cells from column "F2:H2" until the end of spreadsheet.
Sub Copy()
Dim i
For i = 1 To 3
StartRange = "F2:H2"
EndRange = "F2:H2"
Set a = Range(StartRange, Range(StartRange).End(xlDown))
Set b = Range(EndRange, Range(EndRange).End(xlDown))
Union(a, b).Select
Selection.Copy
lastrow = ActiveSheet.Cells(Rows.Count, "T").End(xlUp).Row + 1
Cells(lastrow, "T").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
How to modify the code, if only single item is selected, it will copy the cells in new data table as well?
I can provide a test file for reference.
Use .End(xlDown) from the header row.
Option Explicit
Sub Copy()
Dim ws As Worksheet, rng As Range
Dim i As Long, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
For i = 1 To 3
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).Row + 1
rng.Copy
ws.Cells(lastrow, "T").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
or to copy single rows
Sub Copy2()
Const REPEAT = 3
Dim ws As Worksheet, rng As Range
Dim row As Range, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).row + 1
For Each row In rng.Rows
If Not row.Hidden Then
ws.Cells(lastrow, "T").Resize(REPEAT, row.Columns.Count).Value = row.Value
lastrow = lastrow + REPEAT
End If
Next
End Sub

Replicate a tab in excel

I have a template (named template in the code) and a list of store numbers ( named list in the code). I want to create a new worksheet identical to the template, but replace one cell (E5) with the next number in the list. I have this code but it doesn't seem to work. Any ideas? :
Sub CreateNewSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("List").Range("A2") 'Must change tab name
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets("List").Select
MyCell.Select
Selection.Copy
Sheets(Sheets.Count).Select
Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(Sheets.Count).Name = MyCell.Value & "-" ' renames the new worksheet
Range("E5").Select 'Puts driver name in cell
Next MyCell
End Sub
You are overwriting the range for one thing here:
Set MyRange = Sheets("List").Range("A2") 'Must change tab name
Set MyRange = Range(MyRange, MyRange.End(xlDown))
When I think you want to actually create the range to loop over. Note MyRange.End(xlDown) will take you down to the last non-blank cell in the range rather than the last used row.
So, I have changed your syntax to find the last row, stored in a variable, and use that to define the loop range.
lastRow = ws.Range("A2").End(xlDown).Row
Set MyRange = ws.Range("A2:A" & lastRow)
Then I have put the List worksheet in a variable so you don't need to go backwards and forward selecting sheets.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("List")
This means that whenever you add a sheet, which will become the activesheet, you can simply refer access the MyCell value as it is qualified by the sheet name it came from.
This,
Sheets(Sheets.Count).Name = MyCell.Value & "-"
Looks a bit dodgy in terms of naming. Sort of looks unfinished. However, that should be enough to get you going.
Option Explicit
Sub CreateNewSheet()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("List")
lastRow = ws.Range("A2").End(xlDown).Row
Set MyRange = ws.Range("A2:A" & lastRow)
Dim counter
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
ActiveSheet.Range("E5") = MyCell
Sheets(Sheets.Count).Name = MyCell.Value & "-" ' renames the new worksheet
Next MyCell
End Sub

Loop through dropdown and copy-paste

I'm trying to loop through all values in a dropdown list, the source for which is in sheet "Comm O & S", range A31:L31.
I want to copy values from another sheet that result from the selection in the dropdown and paste these values in a column in a separate sheet (starting at column C). Then, I want to select the next value in the dropdown and copy-paste the values in the next column over, etc.
I am having trouble with the copy-paste within the dropdown loop.
Sheets("Scenario by Payer").Activate
For Each rngCell In wb.Worksheets("Comm O & S").Range("A31:L31")
' Set the value of dd_comm
ws.Range("D14").Value = rngCell.Value
Sheets("Detailed Outputs").Select
Range("T52:t60").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Comm O & S").Activate
For Each c In ActiveSheet.Range("C7:L7").Cells
c.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next rngCell
Next c
Give this a try:
Sub tgr()
Dim wb As Workbook
Dim wsScen As Worksheet
Dim wsComm As Worksheet
Dim wsOuts As Worksheet
Dim rDDList As Range
Dim rDDCell As Range
Dim rDDValue As Range
Dim rCopy As Range
Dim rDest As Range
Set wb = ActiveWorkbook
Set wsScen = wb.Sheets("Scenario")
Set wsComm = wb.Sheets("Comm O & S")
Set wsOuts = wb.Sheets("Detailed Outputs")
Set rDDList = wsComm.Range("A31:L31")
Set rDDValue = wsScen.Range("D14")
Set rCopy = wsOuts.Range("T52:T60")
Set rDest = wsComm.Range("C7")
For Each rDDCell In rDDList.Cells
rDDValue.Value = rDDCell.Value
rDest.Resize(rCopy.Rows.Count, rCopy.Columns.Count).Value = rCopy.Value
Set rDest = rDest.Offset(, rCopy.Columns.Count)
Next rDDCell
End Sub

Do until empty row loop in macro

I have a data file with one column and several rows (dynamic list). I want to transpose the first 28 rows to the first row, the second 28 rows to the second row and so on. I want this to run till an empty row is found. However when i run the code it only transposes the first 28 rows. I have not been able to get results with the "do until empty" loop and am unable to spot the error.
Thanks for your help.
Sub Macro1()
'
' Macro1 Macro
'
'
Range("A1").Select
Do
Range("A1:A28").Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""
End Sub
The macro recorder won't do the loop for you. You do need to pull the Offset out of the loop. Otherwise, fully qualify it:
UPDATE
Option Explicit
Sub CopyPaste()
Dim CopySheet As Worksheet
Dim PasteSheet As Worksheet
Dim MyRange As Range
Dim i As Long
Dim r As Long
Dim wf As WorksheetFunction
Application.ScreenUpdating = False
Set wf = Application.WorksheetFunction
Set CopySheet = ActiveWorkbook.Worksheets("Sheet1")
Set PasteSheet = ActiveWorkbook.Worksheets("Sheet2")
Set MyRange = CopySheet.Range("A1:A28")
r = MyRange.Rows.Count
i = 1
Do Until wf.CountA(MyRange) = 0
MyRange.Copy
PasteSheet.Cells(i, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Set MyRange = MyRange.Offset(r, 0)
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

Resources