I have multiple sheets in a single workbook with values in 5 rows and 5 columns in each sheet. I need to add the corresponding cell values (eg: D5) in each sheet and dump it in a new sheet in its D5. I could do it for one particular cell, but I'm confused on how to do it in nested for loops. I've only been doing vba for a day.. so please help. Thanks.
Sub Macro1()
Dim i, val
'Select worksheets
For i = 7 To Sheets.Count
val = val + Sheets(i).Range("e6")
Next
Sheets("Summation").Range("e6") = val
End Sub
Is this what you want?
Sub Sample()
Dim ws As Worksheet, wsSumry As Worksheet
Dim startRow As Long, StartCol As Long
Dim i As Long, j As Long
Dim ar(1 To 4, 1 To 4) As Variant
'~~> Start row and start column
startRow = 2: StartCol = 2
'~~> Summary sheet
Set wsSumry = Sheet1
'~~> Looping through each worksheet
For Each ws In ThisWorkbook.Worksheets
'~~> Check if it is not the summary sheet
If ws.Name <> wsSumry.Name Then
'~~> Loop through the row and columns and
'~~> Store it in an array
For i = startRow To (startRow + 3)
For j = StartCol To (StartCol + 3)
ar(i - 1, j - 1) = ar(i - 1, j - 1) + ws.Cells(i, j)
Next j
Next i
End If
Next
'~~> Write array to summary sheet
wsSumry.Range("B2").Resize(UBound(ar), UBound(ar)).Value = ar
End Sub
Screenshot
You can use Copy and Add technique, cycling through each sheet that isn't the summisary sheet and then pasting its values in to the final sheet (while adding them) - something like:
Dim b As Worksheet
Set b = ThisWorkbook.Worksheets("Sheet4")
b.range("A1:A2").clear
For Each a In ThisWorkbook.Sheets
If Not a.Name = b.Name Then
a.Range("A1:A2").Copy
b.Range("A1:A2").PasteSpecial operation:=xlAdd
End If
Next
Obviously your range can be defined in place of "A1:A2"
I'm sure there's a more "code" way of adding arrays together but in Excel this might prove good for you.
Related
I will like to Copy and Paste cells in one worksheet with VBA, to another sheet in VBA using a loop.
For example, I will like to copy cell A2 in sheet2 to cell A1 in sheet1, cell B2 in sheet2 to cell B1 in sheet1. Then A3 in sheet2 to cell A1 in sheet1, cell B3 to cell B1 in sheet1. I will like to do this until the last row.
I tried the code below, but my data set is too large. Is there another alternative method?
'Worksheets("Sheet1").Range("C28").Value = Worksheets("Sheet2").Range("B2").Value
hi when im doing things like this i find it easiest to record a macro, then if you go to view your macros and edit them you can see the code that was created. that can be copied straight in to your vba project
OK, I think you might want something along these lines.
Sub x()
Dim r As Long
With Sheet2
For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Sheet1.Range("A1").Resize(, 2).Value = .Cells(r, 1).Resize(, 2).Value
'presumably do something else?
Next r
End With
End Sub
Hi you can use Random number to generate row and column number
Sub test1()
Dim LastRow, Lastcol As Long
Dim wb As Workbook
Dim ws1, ws2 As Worksheets
Set wb = ThisWorkbook
' Sheet name where data is present
Set ws1 = wb.Worksheets("OriginalSheet")
' Sheet name where data to be copied
Set ws2 = wb.Worksheets("CopySheet")
With ws1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
For i = 1 To Lastcol
For j = 1 To LastRow
' Random number generation
' To create a random integer number between two values (range), you can use the following formula:
' Int ((upperbound - lowerbound + 1) * Rnd + lowerbound)
randrow = Int((50 - 10 + 1) * Rnd + 10)
randcol = Int((5 - 2 + 1) * Rnd + 2)
ws2.Cells(randrow, randcol).Value = ws1.Cells(j, i).Value
Next
Next
End Sub
how to use jagged array for copy and pasting specific columns(like B,J,N,M,U,V,) from 12 xl sheets and finally it has to stored in a seperate single sheet.
For Example:
In Sheet1 I need B,J,N,M has to be copied
In Sheet2 I need B,J,N,O,U,V,X,AO to be copied
.
.
.
Upto Sheet12 I need like this specific columns and its values till its last row has to be copied and finally 12 sheet values has to be pasted at the end of the new worksheet.Pls someone help me using vba
I'm gonna try. Is it something like this? Alter the code to your need of course and set more arrays for the column indexes if you need. This will paste all of these columns on a new sheet.
Sub test()
Dim a() As Variant
Dim wb As Workbook
Dim newWS As Worksheet
Dim nextColumn As Long, lastrow As Long, i As Long, o As Long
Set wb = ThisWorkbook
Set newWS = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
a = Array(1, 4, 6, 8, 10, 11) 'column indexes
With wb
nextColumn = 1
For i = 1 To 12
With .Worksheets(i)
For o = LBound(a) To UBound(a)
lastrow = .Cells(65536, a(o)).End(xlUp).Row
.Range(.Cells(1, a(o)), .Cells(lastrow, a(o))).Copy
newWS.Cells(1, nextColumn).PasteSpecial xlPasteAll
nextColumn = nextColumn + 1
Next o
End With
Next i
End With
End Sub
Here is the Macro I've just written out, unfortunately it doesn't seem to do anything and I can't find the error! I am trying to copy the column with the header "Offset Acct" from sheet 1 (SAPDump) to sheet 2 (Extract) which is blank. Can anyone see explain to me why this isn't working? Fairly new to VBA so it's probably an easy fix. Cheers
Sub ExtractData()
' Define sheets
Dim SAPDump As Worksheet
Dim Extract As Worksheet
' Set sheets
Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")
' Define row and column counters
Dim r As Long
Dim c As Long
' Set last non-empty column
Dim lastCol As Long
lastCol = SAPDump.Cells(1, Columns.Count).End(xlToLeft).Column
' Set last non-empty row
Dim lastRow As Long
lastRow = SAPDump.Cells(Rows.Count, "A").End(xlUp).row
' Look a all columns
For c = 1 To c = lastCol
' Examine top column
If SAPDump.Cells(1, c).Value = "Offset Acct" Then
' Loop round all rows
For r = 1 To r = lastRow
' Copy column into A on Extract
Extract.Cells(r, 1) = SAPDump.Cells(r, c)
Next r
Else
End If
Next c
End Sub
You need to change these lines:
For c = 1 To c = lastCol
to
For c = 1 To lastCol
and
For r = 1 To r = lastRow
to
For r = 1 To lastRow
Edit:
A better way may be to do this:
Sub ExtractData()
' Define sheets
Dim SAPDump As Worksheet
Dim Extract As Worksheet
'Define Heading range
Dim rHeadings As Range
Dim rCell As Range
' Set sheets
Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")
'Set Heading range.
With SAPDump
Set rHeadings = .Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft))
End With
'Look at each heading.
For Each rCell In rHeadings
If rCell.Value = "Offset Acct" Then
'If found copy the entire column and exit the loop.
rCell.EntireColumn.Copy Extract.Cells(1, 1)
Exit For
End If
Next rCell
End Sub
The set is not sure, how to run the same within excel macro.
Request you to send the same via .pdf formate.
Regards
Stalin.
I'm currently having problems trying to extract cell data and pasting them into a new workbook. To make things clearer here are the steps
Access a specific worksheet ("Report") in all open workbooks (except the one running the macro)
From the worksheet, extract certain cell data (no. of rows and columns are not fixed but they are identical throughout the open workbooks)
Create a new workbook and paste the data there (each workbook will be assigned one row in the sheet, and all data extracted will be on the same sheet)
I'm having problems with my last sub that extracts this cell data and pastes it into a new workbook, here's what I have so far:
Function Extract_Report_Final(wb As Workbook, book As workbook, counter as long)
Dim last_row, last_col As Long
Dim ws As Worksheet
Dim i, j, k As Integer
Dim data() As String
With wb.Sheets("Report") 'for each worksheet in each open workbook
last_row = .Range("C" & .Rows.Count).End(xlUp).Row
last_col = .Cells(last_row, .Columns.Count).End(xlToLeft).Column
'to get the last row and column where the data required will be located
'this is identical throughout the workbooks as is the name of the worksheet
ReDim data(last_col - 1)
'I decided to use an array to store the values as i don't know how else :(
For k = 0 To (last_col - 2)
Select Case k
Case 0: data(k) = .Cells(1, 1).Value
Case 1: data(k) = .Cells(last_row, 3).Value
Case Else: data(k) = .Cells(last_row, k + 2).Value
End Select
Next k
k = 0
'A weak attempt at trying to copy.paste the values onto a new workbook
'I also don't know how to reference a newly created workbook :(
For i = 1 To last_col
'"book" is the variable workbook which will house the extracted data
.book.ws.Cells(counter, i) = data(k)
k = k + 1
Next i
End Function
Below is my main sub:
Sub Cycle_wb()
Dim ws As Worksheet
Dim wb As Workbook
Dim book As Workbook
Dim counter As Long, last_row As Long, last_col As Long
Dim i, j, k As Integer
Dim data() As String
counter = 1
open_close
Query_Tv_values
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then
MsgBox "working on " & wb.Name
PerLineItem2 wb
Threshold_Value_PayFull wb
End If
Next
'It's just the part below which I'm having issues with :(
Set book = Workbooks.Add
Set ws = book.Sheets.Add(book.Sheets(1))
ws.Name = "Report_Final"
For Each wb In Workbooks
If (wb.Name <> ThisWorkbook.Name Or wb.Name <> book.Name) Then
Extract_Report_Final wb, counter, book
counter = counter + 1
Next wb
End Sub
Just use something like this to fill out the values in your new workbook
Cells(counter, i).Value = data(i-1)
Check the size of you array vs the length of your loops though - I think the "i"-loop should go
For i = 1 To last_col -1
This is my first time to code in VBA.
I have several worksheets in a file and they are in order by dates.
So what I am trying to do is to collect data sets in a worksheet if they have the same period of time.
date1 value1
date2 value2
date3 value3
Since they are in order I just compare the first date values and if they are different it moves on to the next worksheet. If they are the same then copy the value and do the same process until it reaches the last worksheet.
However it copies one worksheet fine but after that Excel freezes.
I would be appreciated if you find any errors or give me other suggestions to do it.
Following is my code:
Sub matchingStock()
Dim sh1 As Worksheet, sh2 As Worksheet
' create short references to sheets
' inside the Sheets() use either the tab number or name
Set sh1 = Sheets("combined")
Dim col As Long
'since first column is for Tbill it stock price should place from the third column
col = 3
Dim k As Long
'go through all the stock worksheets
For k = Sheets("WLT").Index To Sheets("ARNA").Index
Set sh2 = Sheets(k)
' Create iterators
Dim i As Long, j As Long
' Create last rows values for the columns you will be comparing
Dim lr1 As Long, lr2 As Long
' create a reference variable to the next available row
Dim nxtRow As Long
' Create ranges to easily reference data
Dim rng1 As Range, rng2 As Range
' Assign values to variables
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
Application.ScreenUpdating = False
' Loop through column A on sheet1
For i = 2 To lr1
Set rng1 = sh1.Range("A" & i)
' Loop through column A on sheet1
For j = 2 To lr2
Set rng2 = sh2.Range("A" & j)
' compare the words in column a on sheet1 with the words in column on sheet2
'Dim date1 As Date
'Dim date2 As Date
'date1 = TimeValue(sh1.Range("A3"))
'date2 = TimeValue(sh2.Range("A3"))
sh1.Cells(1, col).Value = sh2.Range("A1").Value
' find next empty row
nxtRow = sh1.Cells(Rows.Count, col).End(xlUp).Row + 1
' copy the word in column A on sheet2 to the next available row in sheet1
' copy the value ( offset(0,1) Column B ) to the next available row in sheet1
sh1.Cells(nxtRow, col).Value = rng2.Offset(0, 6).Value
'when the date is different skip to the next worksheet
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
'sh3.Rows("1:1").Delete
Else
GoTo Skip
End If
Skip:
col = col + 1
Next k
End Sub
I cannot identify a specific error so this is a list of suggestions that may help you identify the error and may help improve your code.
Suggestion 1
Do you think the Else block of If-Then-Else-End-If is compulsory?
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
Else
GoTo Skip
End If
Skip:
is the same as:
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
End If
Suggestion 2
I do not like:
For k = Sheets("WLT").Index To Sheets("ARNA").Index
The value of property Index for a worksheet may not what you think it is. This may not give you the set or sequence of worksheets you expect. Do you want every worksheet except "Combined"? The following should be more reliable:
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> sh1.Name Then
:
End If
Next
Suggestion 3
You use:
.Range("A" & Rows.Count)
.Range("A3")
.Cells(1, col).Value
.Cells(Rows.Count, col)
rng2.Offset(0, 6)
All these methods of identifying a cell or a range have their purposes. However, I find it confusing to use more than one at a time. I find .Cells(row, column) and .Range(.Cells(row1, column1), .Cells(row2, column2)) to be the most versatile and use them unless there is a powerful reason to use one of the other methods.
Suggestion 4
I cannot decypher what this code is attempting to achieve.
You say: "I have several worksheets in a file and they are in order by dates. So what I am trying to do is to collect data sets in a worksheet if they have the same period of time."
If you have set Worksheet("combined").Range("A3").Value to a particular date and you want to collect data from all those sheets with the same value in cell A3 then the outer For-Loop and the If give this effect. But if so, if does not matter how the worksheets are ordered. Also you start checking cell values from row 2 which suggests row 3 is a regular data row.
The outer loop is for each worksheet, the next loop is for each row in "combined" and the inner loop is for each row in the worksheet selected by the outer loop. The middle loop does not appear to do anything but set rng1 which is not used.
Perhaps you can add an explanation of what you are trying to achieve.
Suggestion 5
Are you trying to add an entire column of values from the source worksheets to "Combined". The macro below:
Identifies the next free row in column A of "Combined"
Identifies the last used row in column A of "Sheet2"
Assumes the first interesting row of "Sheet2" is 2.
Adds the entire used range of column A of "Sheet2" (complete with formatting) to the end of "Combined"'s column A in a single statement.
This may demonstrate a better way of achieving the effect you seek.
Sub Test()
Dim RngSrc As Range
Dim RngDest As Range
Dim RowCombNext As Long
Dim RowSrcFirst As Long
Dim RowSrcLast As Long
With Worksheets("Combined")
RowCombNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set RngDest = .Cells(RowCombNext, "A")
End With
With Worksheets("Sheet2")
RowSrcFirst = 2
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
Set RngSrc = .Range(.Cells(RowSrcFirst, "A"), .Cells(RowSrcLast, "A"))
End With
RngSrc.Copy Destination:=RngDest
End Sub