I have village names in column A.as below mentioned format
VILLAGE
Campbelbay
Carnicobar
Champin
Chowra
Gandhinagar
Kakana
Kapanga
With this format I have around 700 sheets in workbook. I need to get the same transposed to the below mentioned format in Column(cell) Q1.
Campbelbay,Carnicobar,Champin,Chowra,Gandhinagar,Kakana,Kapanga
I have a macro code works for 8 cells and for one sheet, can somebody help me to apply this macro to all sheets with auto select row number.? i.e, Sheets1 has 30 rows, sheet2 has 50 rows and sheet n has n rows.
I do not have much of knowledge in VB.
Following is the code that works for Sheet1:
Ref:
macro to copy and transpose every seventh row and past in new sheet
Public Sub TransposeData()
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long
Application.ScreenUpdating = False
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow Step 8
.Cells(i, "A").Resize(8).Copy
NextRow = NextRow + 1
.Cells(NextRow, "B").PasteSpecial Paste:=xlPasteAll, transpose:=True
Next i
.Rows(NextRow + 1).Resize(LastRow - NextRow).Delete
.Columns(1).Delete
End With
Application.ScreenUpdating = True
End Sub
You will need to loop the sheets collection worksheets and use the .end something like so
Sub test()
Dim w As Excel.Worksheet
Dim r As Excel.Range
For Each w In ThisWorkbook.Worksheets
Set r = Range("a2", w.Range("a1").End(xlDown))
w.Range("q1").Value = Join(Application.Transpose(r.Value), ",")
Next w
End Sub
Couldn't work out whether you wanted them in the same sheet in Q, if so you'll need to change
w.Range("q1").Value = Join(Application.Transpose(r.Value), ",")
to something like
worksheets("result").range("q1").end(xldown).offset(1,0)=
Hope this helps, not fully tested the last line.
Thanks
Try this
Sub test()
Dim w As Excel.Worksheet
Dim r As Excel.Range
For Each w In ThisWorkbook.Worksheets
Set r = w.Range("a2", w.Range("a1").End(xlDown))
w.Range("q1").Value = Join(Application.Transpose(r), ",")
Next w
End Sub
Related
So I want to copy values from a certain range of cells from worksheet 1-workbook A to worksheet 1- workbook B .
I want to copy everything from the source worksheet: more specifically, every cell that has a value on it.
On the destination worksheet, there are specified cells for the values on source worksheet.
this is my code so far (it's bad, but i'm a noob at VBA!) :
Sub CopyRangeofCells()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\test\template.xlsx")
Set y = Workbooks.Open("C:\test\finalfile.xlsx")
x.Sheets("RDBMergeSheet").Range("A1").Copy
y.Sheets("CW Fast").Range("A1").PasteSpecial
'Close x:
x.Close
End Sub
On my range, I want to do something like Range("A1:LastRow") or anything of the sort. How do I do it? Can I create a lastrow variable and then do ("A1:mylastrowvariable") ??
Hope you can help! VBA is so confusing to me, give me Java all day long! :P
Let's do it step-by-step:
Sub CopyRangeofCells()
Dim x As Workbook
Dim y As Workbook
Dim LastRow As Long
Set x = Workbooks.Open("C:\test\template.xlsx")
Set y = Workbooks.Open("C:\test\finalfile.xlsx")
With x.Sheets("RDBMergeSheet")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A"
.Range("A1:A" & LastRow).Copy
End With
y.Sheets("CW Fast").Range("A1").PasteSpecial xlPasteValues
'Close x:
x.Close
End Sub
Something like this:
Sub CopyRangeofCells()
Dim x As Workbook
Dim y As Workbook
Dim LastRow as Long
Dim LastRowToCopy as Long
Set x = Workbooks.Open("C:\test\template.xlsx")
Set y = Workbooks.Open("C:\test\finalfile.xlsx")
LastRowToCopy = x.Sheets("RDBMergeSheet").Cells(x.Sheets("RDBMergeSheet").Rows.Count, "A").End(xlUp).Row
x.Sheets("RDBMergeSheet").Range("A1:A" & LastRowToCopy).Copy
'copy from A1 to lastrow
LastRow = y.Sheets("CW Fast").Cells(y.Sheets("CW Fast").Rows.Count, "A").End(xlUp).Row + 1 'find the last row
y.Sheets("CW Fast").Range("A" & LastRow).PasteSpecial xlPasteValues
'paste on the lastrow of destination + 1 (so next empty row)
x.Close
End Sub
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
I'm trying to write a macro to loop through every worksheet in the active workbook, and save all formulas as values. To do this, for each sheet, first I run through each pivot table, then select the table and copy & paste as values. Then I am trying to use the worksheet.activerange.value = .value method to save the rest of the cells in the sheet.
I am getting a 1004 runtime error on the line wks.UsedRange.Value = wks.UsedRange.Value.
I have two questions:
1) How can I fix my runtime error?
2) Is there a way to get .value = .value to work with pivot tables? In previous macros this has never worked with pivots, so I have to use copy and paste as below.
Many thanks for your help!
Sub LockWorkbook()
Dim pvt As PivotTable
Dim wks As Worksheet
Dim i As Integer
Dim n As Integer
n = 1
For Each wks In ActiveWorkbook.Worksheets
i = 1
For Each pvt In wks.PivotTables
wks.PivotTables(i).TableRange2.Select
With Selection
.Copy
.PasteSpecial xlValues
.PasteSpecial xlFormats
End With
i = i + 1
Next pvt
Set wks = ActiveWorkbook.Worksheets(n)
wks.UsedRange.Value = wks.UsedRange.Value
n = n + 1
Next wks
End Sub
On The King's point, you can simply copy and paste the whole sheet as values.
Sheets("Sheet1").cells.copy
Sheets("Sheet1").cells.PasteSpecial Paste:=xlPasteValues
If you wanted to throw that in a simple loop to do it to all pages it can look like:
Sub Test1()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
ActiveWorkbook.Worksheets(I).Cells.Copy
ActiveWorkbook.Worksheets(I).Cells.PasteSpecial Paste:=xlPasteValues
Next I
End Sub
Please let me know if that helped!
Latest edit eliminates Run-time error '1004' (excludes Pivot Tables from conversion to values)
Option Explicit
Public Sub ConvertFormulasToValuesInUsedRangeExceptPivotTables()
Dim ws As Worksheet, ur As Range, cel As Range
Dim pvt As PivotTable, nonPivot As Range, isPvt As Boolean
For Each ws In ThisWorkbook.Worksheets
Set ur = ws.UsedRange
For Each cel In ur
For Each pvt In ws.PivotTables 'excludes pivot tables
isPvt = Not Intersect(cel, pvt.TableRange2) Is Nothing
If isPvt Then Exit For
Next
If Not isPvt Then
If Len(cel.Formula) > 0 Then 'excludes empty cells
If nonPivot Is Nothing Then
Set nonPivot = cel
Else
Set nonPivot = Union(nonPivot, cel)
End If
End If
End If
Next cel
nonPivot.Value = nonPivot.Value
Set nonPivot = Nothing
Next ws
End Sub
Essentially Im trying to copy and insert a certain range of cells on the second sheet as the program loops through a range of cells on the first sheet as long as the cells arent empty. I need the copy and insert range to change to the newly copy and inserted cells for each loop. Any help would be much appreciated
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rng As Range
Dim i As Integer
Dim j As Integer
For i = 12 To 24
Set ws = ThisWorkbook.Sheets("Input")
With ws
If Not IsEmpty(Cells(i, 2)) Then
For j = 10 To -2
Set ws = ThisWorkbook.Sheets("Budget Output #2")
With ws
Set rng = .Range("Cell(5,i-j):Cell(17,i-j+1)")
rng.Copy
rng.Offset(0, 2).Insert Shift:=xlToRight
rng.Offset(0, 2).ColumnWidth = 20
Application.CutCopyMode = False
Next j
Next i
End If
End With
End With
End Sub
You do not need the With statements for ONE line. This will be much cleaner. Also with two sheets, you should use TWO sheet variables. Finally, I cleaned up your Range(Cells, Cells) syntax. Although, this will still not work because of your For j = 10 to -2. To move backwards, you have to use a Step -#.
Private Sub CommandButton1_Click()
Dim wsIn As Worksheet, wsOut As Worksheet
Dim rng As Range
Dim i As Integer
Dim j As Integer
Set wsIn = ThisWorkbook.Sheets("Input")
Set wsOut = ThisWorkbook.Sheets("Budget Output #2")
x = 2
For i = 12 To 24
If Not IsEmpty(wsIn.Cells(i, 2)) Then
Set rng = wsOut.Range("B:C")
rng.Copy
rng.Offset(0, x).Insert Shift:=xlToRight
rng.Offset(0, x).ColumnWidth = 20
Application.CutCopyMode = False
x = x + 2
End If
Next i
End Sub
I will let you figure out the answer. Here is the correct structure:
For i ....
For j ...
with ws
end with
next j
next i
You have two ws variables Possibly start your code out right.
Dim ws As Worksheet, sh As Worksheet
Set ws = Sheets("Budget Output #2")
Set sh = Sheets("Input")
I have looked through the other posts about this and have tried adapted the strategies that were recommend by using Set ActiveWorkbook and Set Active Worksheet and I still get the same error. I hope another set of eyes can help out as I am still very new to VBA and I am not all that comfortable with it yet.
Basically the idea is to copy the cells from column f to column j as values as long as the cells of F do not match the cells of J. I get the row count of column E and use that as my count in the for loop.
Code is here:
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim n As Integer
Dim i As Integer
n = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
i = n
For Counter = 1 To n
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
i = i + 1
Next Counter
End Sub
Thanks for the help
Also Edit:
Link to Excel Sheet that has a before page, after first transaction sheet ,and a after second transaction sheet: https://www.dropbox.com/s/n2mn0zyrtoscjin/Rewards.xlsm
CHange this:
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
To this:
Set curCell = Sheets("Calculate").Range("F2:F" & i)
If curCell <> Sheets("Calculate").Range("$J" & i) Then
Sheets("Calculate").Range("$J:$J" &i).Value = curCell.Value
End If
May need to do some more teaking as I notice you're working with SpecialCells which essentially filters the range, so iterating For i = 1 to n... probably does not work. Maybe something like:
Dim rngCalc as Range
Set rngCalc = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants)
For each curCell in rngCalc.Cells
If curCell <> curCell.Offset(0, 4) Then
curCell.Offset(0, 4).Value = curCell.Value
End If
Next
EDIT: this sub will calculate the points for the last transaction (identified as the furthest-right column containing transactions) and write them down in column C.
Option Explicit
Sub UpdateCurrentPurchase()
Dim CalcSheet As Worksheet
Dim LastTransRange As Range, TargetRange As Range
Dim LastTransCol As Long, LastTransRow As Long
Dim PurchaseArray() As Variant
Dim Points As Long, Index As Long
'set references up-front
Set CalcSheet = ThisWorkbook.Worksheets("Calculate")
With CalcSheet
LastTransCol = .Cells(2, .Columns.Count).End(xlToLeft).Column '<~ find the last column
LastTransRow = .Cells(.Rows.Count, LastTransCol).End(xlUp).Row
Set LastTransRange = .Range(.Cells(2, LastTransCol), .Cells(LastTransRow, LastTransCol))
Set TargetRange = .Range(.Cells(2, 6), .Cells(LastTransRow, 6)) '<~ column F is the Current Purchase Col
LastTransRange.Copy Destination:=TargetRange '<~ copy last transactions to Current Purchase Col
End With
'pull purchases into a variant array
PurchaseArray = TargetRange
'calculate points
For Index = 1 To LastTransRow
Points = Int(PurchaseArray(Index, 1) / 10) '<~ calculate points
CalcSheet.Cells(Index + 1, 3) = Points '<~ write out the points amount in col C
Next Index
End Sub
ORIGINAL RESPONSE: I think the below will get you where you're going. That being said, it seems like simply overwriting column J with column F (as values) might be the fastest way to an acceptable answer, so if that's the case we can re-work this code to be much quicker using Range objects.
Option Explicit
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim LastRow As Long, Counter As Long
Dim cSheet As Worksheet '<~ add a worksheet reference to save some typing
'set references up front
Set cSheet = ThisWorkbook.Worksheets("Calculate")
With cSheet
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row '<~ set loop boundary
'loop that compares the value in column 6 (F) to the value in
'column 10 (J) and writes the value from F to J if they are not equal
For Counter = 1 To LastRow
If .Cells(Counter, 6).Value <> .Cells(Counter, 10).Value Then
.Cells(Counter, 10) = .Cells(Counter, 6)
End If
Next Counter
End With
End Sub