I've been a longtime viewer of this place and I love it! I've never needed to post because I've been able to find everything. However, today I am stumped and I cannot find an answer here so forgive me if this has been addressed.
The question is this:
I want to copy ColumnA (starting say, A2) from SHEET1 into ColumnB (starting B8) of SHEET2.
My problem is that the source column (SHEET1:ColumnA) has a dynamic number of rows every instance the workbook is used. I also do not want to fill down to the end of the sheet or display zeros etc.
I perceive this as a filldown problem but sourcing from another sheet. Though I may be wrong about that and cannot make it work myself.
Thanks very much in advance.
Try this:
sub copyToOtherSheet()
dim startRowASht1 as int
dim startRowSht2 as int
dim loopr as Boolean
dim counter as long
loopr = True
counter = 0
startRowSht1 = 2
startRowSht2 = 8
Do While loopr = True
Worksheets("Sheet2").Range("B" & Cstr(startRowSht2 + counter)).value = Worksheets("Sheet1").Range("A" & Cstr(startRowSht2+counter)).value
if Cstr(worksheets("Sheet1").Range("A" & Cstr(startrowsht2 + counter)).value) = "" then
loopr = False 'you reached an empty cell and it stops copying
else
counter = counter + 1
end if
End Sub
Public Sub a()
With Sheets("Sheet2")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Copy Destination:=Sheets("Sheet1").Cells(8, 2)
End With
End Sub
If you are willing to use a macro:
Sub copyRange()
Dim rSource As Range
Set rSource = Range(Sheet1.Cells(2, 1), Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp))
Range(Sheet2.Cells(8, 2), Sheet2.Cells(Sheet2.Rows.count,2)).Clear
Range(Sheet2.Cells(8, 2), Sheet2.Cells(7 + rSource.Rows.Count, 2)).Value = rSource.Value
End Sub
This assumes that there is nothing below the contiguous range of values in column A on Sheet1, and that in Sheet2 you want to completely clear out whatever is in column B from row 8 down to the bottom. (If your range in column A of Sheet1 gets smaller from one invocation to the next, you don't want to leave any remnants in Sheet2)
Related
First of all I would like to introduce myself. Iam Miguel and I recently started to learn VBA in order to improve and save time at work. I am familiar with formulas, all types, but when turning to VBA I get sometimes stuck.
I am trying to loop the range A2:A355 from Sheet"Aux" and copy each value to sheet "CS", and each value shall be pasted in Column A:A, but with the offset given in range B2:B355 Sheet "Aux". For Example I give the example attached.
Sample Code:
This is the code:
Sub cablexsection()
Dim s As Integer
Dim smax As Integer
smax = Sheets("Aux").Range("b1").Value
Sheets("CS").Activate
For s = 3 To smax
Sheets("CS").Cells(s, 1).Value = Sheets("Aux").Cells(s, 1).Value
'here I have to set the offset to down in order to paste cells given Sheets("Aux").Cells(s, 2) values
Next s
End Sub
And under the link you can find the file to be worked in:
Original File
Thank you very much and sorry if this question is repeated. I have tried to look through the forum but maybe I do not know what to write exactly.
Try this
Option Explicit
Sub CableXsection()
Dim wsAux As Worksheet, wsCS As Worksheet
Dim s As Long, sMax As Long, offSetCell As Range
Set wsAux = ThisWorkbook.Worksheets("Aux")
Set wsCS = ThisWorkbook.Worksheets("CS")
sMax = wsAux.Range("B1").Value
Application.ScreenUpdating = False
For s = 3 To sMax
Set offSetCell = wsAux.Cells(s, 2) '2 is the offset column from the same row
If Not IsError(offSetCell) And IsNumeric(offSetCell) Then
wsCS.Cells(offSetCell.Value2 + s, 1).Value = wsAux.Cells(s, 1).Value
End If
Next
Application.ScreenUpdating = True
End Sub
I´m trying to do a VLOOKUP of a column data set at a Sheet called "SyS" in G column. and I'd like to Vlookup relevant data using columns in another sheet called "CONF_mapping", located in the same Workbook. I need to find my data located at the range ("A1:E65000") (It's at column A, but I need to retrieve data from other columns with my vlookup to SyS). I'm not getting good results with my code, and I beg your pardon, it´s my first question in the forum.
Worksheets("SyS").Select
Dim wsThis As Worksheet
Dim aCell As Range
Sheets("CONF_mapping").Columns(2).Copy Destination:=Sheets("SyS").Columns(8)
Set wsThis = Sheets("SyS")
With wsThis
For Each aCell In .Range("A1:E65000")
'.Cells(aCell.Row, 8) = "Not Found"
On Error Resume Next
.Cells(aCell.Row, 8) = Application.WorksheetFunction.VLookup( _
aCell.value, wsThat.Range("G2:G65000"), 2, False)
On Error GoTo 0
Next aCell
End With
Worksheets("SyS").Select
I have find this code but I was not able to make it works for me.
I would appreciate any help.
You have mistake here:
VLookup(aCell.value, wsThat.Range("G2:G65000"), 2, False)
Range "G2:G65000" Have just 1 column G, but you try to get column#2 which does not exists.
UPD:
I guess you need something like this:
Const COLUMN_TO_MATCH_IN_SYS = 8
Const COLUMN_TO_MATCH_IN_CONF = 1
Sub test()
Dim wsSys As Worksheet
Dim wsConf As Worksheet
Set wsSys = Sheets("SyS")
Set wsConf = Sheets("CONF_mapping")
Dim RowSys As Range
Dim RowConf As Range
For Each RowSys In wsSys.UsedRange.Rows
For Each RowConf In wsConf.UsedRange.Rows
If RowSys.Cells(1, COLUMN_TO_MATCH_IN_SYS) = _
RowConf.Cells(1, COLUMN_TO_MATCH_IN_CONF) Then
' Copy row values which is needed
RowSys.Cells(1, 6) = RowConf.Cells(1, 1) ' From column A(conf) to G(sys)
RowSys.Cells(1, 7) = RowConf.Cells(1, 2) ' From column B(conf) to H (sys)
End If
Next aCell
Next
End Sub
With this solution you don't need to search the Range for each cell (just for each row), so it will work 5 times faster.
Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays
I have data that I am working to Parse Out that I have imported from approval emails sent in Outlook. At this point I am just importing the CreationTime and the SubjectLine.
For the subject line I am able to use the Split function to separate out most of the data. I then am left with Job Codes in Column B and Position numbers in Column C which includes the text: "Job Codes: XXXX" and the four digit job code number and "PN XXXX" and either a four digit or 6 digit position number. I am trying to use the Right functionality to loop through the entire column and reformat the column just to show only the four digit job code number for Column B and either just the 4 digit or 6 digit position number (the actual numbers) for Column C
For Job Code Column B:
Currently my code works for Shortening the Job Codes but it involves adding a column, putting the RIGHT formula in that column for the shortened Job Code, then copying and pasting the formula as values back into the column and then deleting the original column.
The problem- Works but perhaps not the most efficient with a larger data set (currently 200 rows but will have 2000 or more)
Code:
Sub ShortenJobCodes()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC3,4)"
Dim oRng As Range
Dim LastRow As Long
Range("B1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set oRng = Range("B:B")
Range(oRng, Cells(LastRow, "B")).FormulaR1C1 = R4Col
Set oRng = Nothing
Columns("B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
For Position Numbers Column C:
Currently I have mirrored the above code but added in an if statement using LEN to count if the characters are less than 8, if so then insert one RIGHT function if not insert the other RIGHT function. This also involves adding an additional column putting the RIGHT formula in that column for the shortened Position Number(Eliminating all but just the number), then copying and pasting the formula as values back into the column and then deleting the original column.
Problem - This works but seems to take forever to process and in fact looks like it is in an infinite loop. When I Esc out of it, it does add the column and then input the proper RIGHT formula (leaving just the numeric values) but the sub never seems to end, nor does it copy and paste the formulas as values or delete the original column. As noted above I realize this is likely a more efficient way to do this but I have tried a bunch of options without any luck.
I am realizing part of the loop might be due to the range itself being an entire column but I cannot find a way to stop that with the last row (even though I have a count in there).
Code:
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC4,4)"
Const R6Col = "=RIGHT(RC4,6)"
Dim oRng As Range
Dim rVal As String
Dim y As Integer
Dim selCol As Range
Dim LastRow As Long
Range("C1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = Range("D:D")
For Each oRng In selCol
oRng.Select
rVal = oRng.Value
If Len(oRng.Value) > 8 Then
oRng.Offset(0, -1).FormulaR1C1 = R6Col
Else
oRng.Offset(0, -1).FormulaR1C1 = R4Col
End If
Next
Set oRng = Nothing
Columns("C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("D1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Major Question: Is there a way to use RIGHT/TRIM/LEN/LEFT functions to do this within a cell without having to add columns/delete columns and insert functions?
There are a few things you can do here to speed up your code. I'm only going to reference the second code block as you can apply similar logic to the first.
The first issue is that you create a LastRow variable but never reference it again. It looks like you meant to use this in the selCol range. You should change that line to Set selCol = Range("C1:C" & lastRow). This way, when you loop through the rows you only loop through the used rows.
Next, in the For-Each loop you Select every cell you loop through. There really isn't any reason to do this and takes substantially longer. You then create the variable rVal but never use it again. A better way to set up the loop is as follows.
For Each oRng in selCol
rVal = oRng.Value
If Len(rVal) > 8 Then
oRng.Value = Right(rVal, 6)
Else
oRng.Value = Right(rVal, 4)
End If
Next
This is much cleaner and no longer requires creating columns or copying and pasting.
Try this, it uses Evaluate and no loops or added columns.
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Dim selCol As Range
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = .Range(.Cells(1, 3), .Cells(LastRow, 3))
selCol.Value = .Evaluate("INDEX(IF(LEN(" & selCol.Address(0, 0) & ")>8,RIGHT(" & selCol.Address(0, 0) & ",6),RIGHT(" & selCol.Address(0, 0) & ",4)),)")
End With
Application.ScreenUpdating = True
End Sub
Or work with arrays
Sub ShortenPositionNumbers()
Dim data As Variant
Dim i As Long
With Range("C3:C" & Cells(Rows.Count, "A").End(xlUp).Row)
data = Application.Transpose(.Value)
For i = LBound(data) to UBound(data)
If Len(data(i)) > 8 Then
data(i) = RIGHT(data(i),6)
Else
data(i) = RIGHT(data(i),4)
End If
Next
.Value = Application.Transpose(data)
End With
End Sub
I'm trying to use the trim function without success. After searching for the solution on this forum and other sources online I have seen many different approaches.
Is there no simple way of trimming a cell in VBA?
What I want is something like this:
Sub trimloop()
Dim row As Integer
row = 1
Do While Cells(row, 1) <> ""
Cells(row, 2) = trim(Cells(row, 2))
row = row + 1
Loop
So that when there is a value in column A (1) the value in column B (2) should be trimmed of any extra spaces. I just cant get this to work for me.
Appreciate any help/tips!
Regards
Jim
So i made the code a bit accurate and mistakeproof and it worked.
So i can recommend you to double check, if you have correct row and column values, because you probably targeting wrong cells. (cause your code is working)
Sub trimloop()
Dim row As Integer
Dim currentSheet As Worksheet
Set currentSheet = sheets("Sheet1")
row = 2
Do While currentSheet.Cells(row, 1) <> ""
currentSheet.Cells(row, 2).Value = Trim(currentSheet.Cells(row, 2).Value)
row = row + 1
Loop
End Sub
Use Application.WorksheetFunction.Trim(string)
Sub trimloop()
Dim row As Integer
row = 1
With ThisWorkbook.ActiveSheet
Do While .Cells(row, 1) <> ""
.Cells(row, 2) = Application.WorksheetFunction.Trim(.Cells(row, 2))
row = row + 1
Loop
End With
End Sub
this is the optimized version of your code, in case of big data sheets:
Option Explicit
Sub trimloop()
Dim row As Long, max As Long
Dim Data() As Variant
With ThisWorkbook.Sheets(1)
max = .Cells(1, 1).End(xlDown).row 'this does the same as your code, on first empty cell it stops
'the following finds the last un-empty cell of column(1):
'max= .cells(.rows.count,1).end(xlup).row
'copies values from sheet to memory (is faster for working with later)
Data = .Range(.Cells(1, 1), .Cells(max, 2)).Value2
'loop :
For row = 2 To max + 1
'work with memory instead of sheet
Data(row, 2) = Trim(Data(row, 2))
'for complete delete of all spaces use : = replace( StringName," ", "")
Next row
'write back to sheet
.Range(.Cells(1, 1), .Cells(max, 2)).Value2 = Data
End With
erase Data 'free memory
End Sub
Don't know if this overly simplified... but thought I would simply throw it out there this worked for me. The only predecessor step is you assign a "named range" to your workbook/worksheet/dataset ... name a data set and then iterate over the data set with this code
Sub forEachLoop()
For Each cell In Range("yourNamedRange")
cell.Value = Trim(cell.Value)
Next cell
End Sub