Loop throug column and paste values to an existing workbook - excel

Hi this is my first post and i am newbie when it comes to VBA.
So i tried the last 6 hours to accomplish one task.
I already managed to get the code for the For each loop and it works and copies the value to the existing workbook. But i couldnt find out why it always copies the value to A2 and not further to A3/A4/A5 and so on .
I tried these piece of code " range = range + 1 " but i keep getting runtime errors and it still copies the values to A2 and overwrites it when it gets a new value from the loop.
I think its only a litte change needed but i cant figure it out. :(
Sub copie1()
Dim ws As Worksheet
Dim cell As Range
Dim targetsheet As Worksheet
Dim target As Range
Dim rngTemp As Range
Set wkba = ActiveWorkbook
Worksheets("cop1").Activate
LR = Cells(Rows.Count, "A").End(xlUp).Row
LT = Cells(Rows.Count, "X").End(xlUp).Row
Set rngTemp = Range("X2:X" & LT)
Workbooks.Open Filename:="C:\Users\path......."
Set targetsheet = Worksheets("Data")
Set target= targetsheet.Range("A1")
For Each cell In rngTemp
If cell > 0 Then
target.Offset(1, 0) = cell.Value
End If
target = target+1 '// is this right?
Next cell
End Sub
my goal is the loop through column X in a Workbook and copy every single data that is bigger than 0 ( because there are empty cells & cells with value 0)
and paste it in an existing workbook in range A2/A3/A4 and so on

You can't add the number one to a Range object.
Try replacing target = target+1 '// is this right? with:
Set target = target.Offset(1)
Does this resolve the problem?

SibSib1903, I have added below a simple example that you can easily adapt to your own requirements. It looks at all cell values in column A and any numeric value greater than zero is copied to column C starting in row 1. For example, if column A contains 45 rows with data, and only three of these rows have a numeric value greater than zero, these three values will copied in column C in the first three rows.
Public Sub copieTest()
Dim ws As Worksheet, cell As Range, rngX As Range
Dim tmpVal As Variant, counter As Long
Set ws = ThisWorkbook.Worksheets("cop1")
Set rngX = ws.Range("A1:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row)
counter = 1
For Each cell In rngX
tmpVal = Val(Trim(cell.Value))
If tmpVal > 0 Then
ws.Range("C" & counter).Value = tmpVal
counter = counter + 1
End If
Next cell
Set rngX = Nothing: Set ws = Nothing
End Sub

Related

Copying an array of dynamic ranges, starting from searched cell value

I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help

Stack different columns into one column on a different worksheet

I want to copy all filled cells starting from C5 to column F of a different worksheet.
I referred to another post: Excel - Combine multiple columns into one column
Modified the code based on my needs.
Sub CombineColumns()
Dim Range1 As Range, iCol As Long, Range2 As Range, Check As Range, wks As Worksheets
Set Range1 = wks("T(M)").Range(Cells(5, 3), Cells(Cells(5, 3).End(xlDown).Row, Cells(5, 3).End(xlToRight).Column))
Set Check = wks("csv").Range("F1")
If IsEmpty(Check.Value) = True Then
Set Range2 = Check
Else
LastRow = wks("csv").Range("F" & Rows.Count).End(xlUp).Row
Set Range2 = wks("csv").Cells(LastRow, 6).Offset(1, 0)
End If
For iCol = 3 To Range1.Columns.Count
wks("T(M)").Range(Cells(5, iCol), Cells(Range1.Columns(iCol).Rows.Count, iCol)).Copy
wks("csv").Range2.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next iCol
End Sub
But I kept getting the error message
"object doesn't support this method or property"
at the step of pasting. After I tried to qualify all the ranges, It says I didn't set the object variable.
Thank you so much for the help!
How about this?
Sub Transposes()
' Example just for hardcoded data
Dim inputRange As Range
Set inputRange = Sheets("Sheet1").Range("C5:F10").SpecialCells(xlCellTypeConstants)
Dim outputCell As Range
Set outputCell = Sheets("Sheet2").Range("A1")
Dim cell As Range
For Each cell In inputRange
Dim offset As Long
outputCell.offset(offset).Value = cell.Value
offset = offset + 1
Next cell
End Sub
Set the last row in ColumnF to be whatever you want, and if that changes dynamically, just use any one of the multiple techniques out there to find the last cell you need to copy/paste.

Create a named range based on a value in another column not included in range

I have a data set, 10 columns wide, with an ever increasing number of rows.
In column C I have a set of features, e.g. "Search" that will have a few rows corresponding to it; ""Filter" that will have a few rows corresponding to it and so on. However, these could be in any order, so I could have some "Search" features and then some "Filter" features and then some more "Search" features...
I need to create a named range for selected cells in columns D:F where the value in C is the feature I require. This would be for example a named range called "T1" that goes from D3:F6 and maybe D71:F71 for all the "Search" features, but not the "Filter" features.
I have tried using Offset and Count in the Name Manager. But ideally, I need to use VBA in my already existing macro so I don't need to go in and change the Named Ranges every time a new row is added.
Ideally the code would be along the lines of...
If column C contains the word "Filter", make a named range for the three columns to the right of it, every time the word "Filter" occurs.
I used Offset and Count in the name manager:
=OFFSET(Features!$D$3, 0, 0, COUNTA(Features!$D$3:$D$9), COUNTA(Features!$D$3:$F$3))
Sub mySub()
Dim Features As Worksheet
Dim myNamedRange As Range
Dim myRangeName As String
Set Features = ThisWorkbook.Worksheets("Search")
If Range.("C") is "Search"
Set mRangeName= myWorksheet.Range("D:F")
myRangeName = "Search"
ThisWorkbook.Names.Add Name:=Search, RefersTo:=myNamedRange
End Sub
Any help would be greatly greatly appreciated. I hope I have clarified the problem enough.
If I understand correctly then you could try something like the following:
Sub test()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error
For Each cell In featuresRng 'loop through the range of features
If cell.Value = "search" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
sht.Names.Add "Something", rng
End Sub
The code above, loops through the range of features and whenever a cell whose value is "search" is found, it adds the corresponding D, E and F cells in a range. In the end you have a total range which you can name whatever you want.
For example, if you have the following set-up:
Then what you'll get is this:
So the resulting range address would be $D$1:$F$2,$D$8:$F$8,$D$10:$F$12,$D$15:$F$19
Now, if you want individual named ranges to be created every time the keyword is found you can modify the code accordingly like so:
Sub test2()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0
For Each cell In featuresRng
If cell.Value = "search" Then
counter = counter + 1
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
sht.Names.Add "Something" & counter, rng
End If
Next cell
End Sub

How to copy range from multiple sheets to one sheet (one range under another) if a condition is met?

I have and excel workbook with multiple sheets and I need a range from each one to be copied into one "Main" sheet (one under another) if a condition is met.
Each sheet is different and the number of rows and cells may vary.
In all of the sheets (except the main sheet which is blank) cell B1 is a check cell that contains "yes" or is blank.
If cell B1 ="yes" the macro must migrate the range (from row 2 to the lat filled in row) into the main sheet.
The selected ranges must be copied one under another in the main sheet (so that it's like a list)
I am still a beginner in VBA and if anyone could help me a little with the code I would very much appreciate it :).
I tried to build in the code using "For Each - Next" but perhaps it would be better to make it with a Loop cicle or something else.
Sub Migrate_Sheets()
Dim wksh As Worksheet, DB_range As Range, end_row As Long, con_cell As Variant
con_cell = Range("B1")
'end_row = Range("1048576" & Rows.Count).End(xlUp).Rows
For Each wksh In Worksheets
If con_cell = "Yes" Then
Set DB_range = Range("2" & Rows.Count).End(xlDown).Rows
DB_range.Copy
wksh("Main").Activate
'row_end = Range("2" & Rows.Count).End(xlUp).Rows
Range("A1").End(xlDown).Offset(1, 0).Paste
End If
Next wksh
End Sub
There are quite a few issues here - I suggest you do some reading on VBA basics - syntax, objects, methods etc.
I've assumed you are only copying column B.
Sub Migrate_Sheets()
Dim wksh As Worksheet, DB_range As Range
For Each wksh In Worksheets
If wksh.Name <> "Main" Then 'want to exclude this sheet from the check
If wksh.Range("B1").Value = "Yes" Then 'refer to the worksheet in the loop
Set DB_range = wksh.Range("B2", wksh.Range("B" & Rows.Count).End(xlUp)) 'you need Set when assigning object variables
DB_range.Copy Worksheets("Main").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 'better to work up from the bottom and then go down 1
End If
End If
Next wksh
End Sub
See if this helps, though you might need to make some minor changes to match your data sets..
Sub Migrate_Sheets()
Dim wksh As Worksheet, mainWS As Worksheet
Dim DB_range As Range, con_cell As String
Dim lRow As Long, lCol As Long, lRowMain As Long
Set mainWS = ThisWorkbook.Worksheets("Main")
For Each wksh In Worksheets
con_cell = wksh.Range("B1").Value 'You want to use this variable within the loop
If wksh.Name <> "Main" And con_cell = "Yes" Then
lRowMain = lastRC(mainWS, "row", 1) + 1 'Add 1 to the last value to get first empty row
lRow = lastRC(wksh, "row", 1) 'Get the last row at column 1 - adjust to a different column if no values in column 1
lCol = lastRC(wksh, "col", 2) 'Get the last column at row 2 - adjust to a different row if no values in row 2
With mainWS
.Range(.Cells(lRowMain, 1), .Cells(lRowMain + lRow - 1, lCol)).Value = wksh.Range(wksh.Cells(2, 1), wksh.Cells(lRow, lCol)).Value
End With
End If
Next wksh
End Sub
Function lastRC(sht As Worksheet, RC As String, Optional RCpos As Long = 1) As Long
If RC = "row" Then
lastRC = sht.Cells(sht.Rows.Count, RCpos).End(xlUp).row
ElseIf RC = "col" Then
lastRC = sht.Cells(RCpos, sht.Columns.Count).End(xlToLeft).Column
Else
lastRC = 0
End If
End Function

VBA to add totals and formula to multiple sheets

I have an excel sheet with around 200 work sheets each containing a list of products sold to a company.
I need to add
A total at the bottom of row D-G where the bottom can be a different value. I.E. E4
below the total a formula based on the total. I.E. if E4 (being the bottom of the above row) is below $999 the display text "samples", if between 1000-3000 then multiply E4 by 2%, 3001-7500 x 5% etc.
I need to be able to add it to the entire workbook easily using vba. Since I must do this to numerous ss it would literally save me 15-20 hours a month.
Edit:
So I have something that seems to be the right path.
Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))
'Delete any sheet called "UniqueList"
'Turn off run time errors & delete alert
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"
'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A3", .Range("A65536").End(x2Up))
End With
On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add().Name = strText
'Copy the visible filtered range _
(default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With wSheetStart
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
Dim colm As Long, StartRow As Long
Dim EndCell As Range
Dim ws As Worksheet
StartRow = 3
For Each ws In Worksheets
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
If EndCell.Row > StartRow Then EndCell.Resize(, 4).Formula = "=SUM(R" & StartRow & "C:R[-1]C)"
Set EndCell = ws.Cells(Rows.Count, "D").End(xlUp)
If EndCell.Row >= 1000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.05))
Range(J3) = "5% Discount"
ElseIf EndCell.Row >= 3000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.1))
Range(J3) = "10% Discount"
End If
Next ws
End Sub'
Just need to figure out how to display the results and text to the right cells (J2 in this case)
I will supply the logic and all the references you need to put this one together; and will let you try to put it together on your own :). Come back for more help if needed.
You need to loop through all the worksheets in your workbook (Microsoft Tutorial)
You need to find the last row for the given columns (Online tutorial)
You need to use an IF statement to choose which formula to use (MSDN reference)
UPDATE
What's wrong with your code is this line :
Range(J2) = Formula = ((EndCell.Row) * (0.1))
What you're telling the computer is :
Multiply EndCell.Row by 0.1 (which has the number of the row below and to the right of the last cell in column C)
Compare Formula with the result previously obtained
Store the result of that logical expression at the range stored in variable J2
First of all, what you want is to put the result of the equation, and want to change J2 to "J2" so it gets the cell J2, instead of the what's contained in J2 (which has nothing at that point)
Also, you seem to say that you're not getting the right cells, maybe it is caused by this :
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
In that line, you're finding the last cell of column C, but then you select the cell below, and to the right of it.
There are so many things wrong with your code it's hard to say what's not working properly.

Resources