I am very new to VBA and I am trying to solve what I think should be a very simple problem (I have a Java/J2EE background)... I am looping through a table and want to copy rows to a table on another worksheet based on some conditional statements. See code below.
Sub closeActionItems()
Dim i, iLastRow As Integer
Dim date1 As Date
Dim oLastRow As ListRow
date1 = Date
iLastRow = ActiveSheet.ListObjects("Open_Items").ListRows.Count
For i = 6 To iLastRow
If Cells(i, 7).Value <= date1 And Cells(i, 7).Value <> vbNullString Then
Rows(i).Copy
Set oLastRow = Worksheets("Closed").ListObject("Closed_Items").ListRows.Add
'Paste into new row
Application.CutCopyMode = False
Rows(i).EntireRow.Delete
End If
Next
End Sub
I have tried many different iterations but have been unable to find the correct way to copy the contents of the clipboard to the newly created row.
Any help would be appreciated. Thanks ahead of time.
Define srcRow as a Range like so:
Dim srcRow as Range
Then in your loop try doing this:
Set srcRow = ActiveSheet.ListObjects("Open_Items").ListRows(i).Range
Set oLastRow = Worksheets("Closed").ListObjects("Closed_Items").ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Rows(i).EntireRow.Delete
Notice that you still have a problem in that you are deleting rows as you are trying to loop through them, so you probably want to change your loop so that it starts at the bottom and goes up.
Related
I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA.
I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value.
my code below.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In rng
If CStr(xCell.Value) = "USD" Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = xCell.Value
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = xCell.Value
Application.CutCopyMode = False
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria,
i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added,
also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.
you may want to try this code, exploiting Autofilter() method of Range object
Option Explicit
Sub SortCurrency()
Dim currRng As Range, dataRng As Range, currCell As Range
With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.Rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.name = shtName
End If
End Function
You're pretty close with what you've got, but there's a few things to note:
On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.
xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.
Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.
All told, the below code should be close to what you're looking for.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim targetSheet As Worksheet
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
Application.ScreenUpdating = False
For Each xCell In rng
Set targetSheet = Nothing
On Error Resume Next
Set targetSheet = Sheets(xCell.Value)
On Error GoTo 0
If targetSheet Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Set targetSheet = Sheets(Sheets.Count)
targetSheet.Name = xCell.Value
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
Else
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.
1 - You could do with testing whether a worksheet already exists rather than creating it every time
Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.
First of all you need a seperate function to test whether the sheet exists, like
Public Function DoesSheetExist(SheetName as String)
On Error Resume Next
Dim WkSheet as WorkSheet
'sets worksheet to be the sheet NAMED the current currency name
Set WkSheet = Sheets(SheetName)
'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists
If WkSheet is Nothing Then
DoesSheetExist = False
Else
DoesSheetExist = True
End If
End Function
You can then call this function in your code, and only create new sheets when you need to
2 - The loop itself
So instead, I would suggest your loop probably wants to look more like this:
Dim xSheet as Worksheet 'declare this outside the loop
For Each xCell In rng
If DoesSheetExist(xCell.Value) Then
set xSheet = Sheets(xCell.Value) 'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index
Else
set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
xSheet.Name = xCell.Value
End if
With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in
3 - the copy/paste line itself
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1
I think what you actually wanted to say was this:
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
However, if you're using the code I gave you above you can instead use this now:
xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)
In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist
Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.
I have data in about 50 sheets and structure for all of them are same. Please find data structure in an example below, in column May will be data and in next column letter for example "B" or "AB". I want to merge those two columns in one, so my data shold looks like 236AB. My code should work for all columns in sheets, because in some sheets I have 5 columns and in another 25. Anybody can help me with this one? Thank so much!
I have attach code for your requirement, It will automatically search for May and June keyword and will perform concatenation for that particular columns alone.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Ws As Worksheet
Dim monthss(12) As String
monthss(1) = "May"
monthss(2) = "June"
monthss(3) = "August"
For Each Ws In wb.Worksheets
For j = 1 To 3
With Ws.UsedRange
Set c = .Find(monthss(j), LookIn:=xlValues)
If Not c Is Nothing Then
firstrow = c.Row
firstcol = c.Column
End If
End With
Set c = Nothing
lastrow = Ws.Cells(Ws.Rows.Count, firstcol).End(xlUp).Row
' For May Sheet
If firstrow > 0 Then
For i = firstrow + 1 To lastrow
Ws.Cells(i, firstcol).Value = Ws.Cells(i, firstcol).Value & Ws.Cells(i, firstcol + 1).Value
Next
firstrow = 0
End If
' for June Sheet
Next j
Next Ws
End Sub
Not 100% sure what your end goal is but could you not add a new column on the left and make it's formula be CONCATENATE(A1:E1) and make it go as far down the sheet as you need it?
Then if you need to afterwards you could copy paste values that column and delete the others.
All fairly quick to do even if recording in excel.
Do you want to give that a go and post back if you get stuck?
Here is a Function that merges 2 Columns together:
Function mergeColumns(mergeColumn As Integer)
Dim i As Integer
'Adjust startvalue(1)
For i = 1 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row Step 1
'Combine mergeColumn and Column next to it
Cells(i, mergeColumn).Value = Cells(i, mergeColumn).Value & Cells(i, mergeColumn + 1).Value
'Clear the Content of the Cell next to Mergecolumn
Cells(i, mergeColumn + 1).Value = ""
Next i
End Function
Lets say you want to merge column A and B, the call would be mergeColumns 1
Now work out a routine to find the right columns to merge.
I'm brand new to VBA for excel (like a few hours ago new) and not really a programmer, so bear with me.
I have an excel data set, all in one column (column A) that is structured like this:
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
That is, the data blocks are separated by blank rows, but not at regular intervals. I'm trying to write a macro that will go through the file and Group (the specific excel command) these blocks of data together. So far I have this:
Set firstCell = Worksheets("627").Range("A1")
Set currentCell = Worksheets("627").Range("A1")
Do While Not IsEmpty(firstCell)
Set firstCell = currentCell
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If IsEmpty(nextCell) Then
Range("firstCell:currentCell").Select
Selection.Rows.Group
Set firstCell = nextCell.Offset(1, 0)
Else
Set currentCell = nextCell
End If
Loop
Loop
I'm sort of stuck, having particular trouble with the logic of moving to the next block of data and initiating.
Any help would be appreciated!
How about something like this:
Option Explicit
Public Sub tmpTest()
Dim i As Long
Dim lngLastRow As Long
With ThisWorkbook.Worksheets(1)
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lngLastRow To 1 Step -1
If .Cells(i, 1).Value2 = vbNullString Then
.Range(.Cells(i + 1, 1), .Cells(lngLastRow, 1)).EntireRow.Group
lngLastRow = i - 1
End If
Next i
.Range(.Cells(1, 1), .Cells(lngLastRow, 1)).EntireRow.Group
End With
End Sub
Here ya are. You just need to pull addresses in your range instead of trying to refer to the object. You also need to reset both current and first cell in your if statement.
Sub test()
Set firstCell = Worksheets("test2").Range("A1")
Set currentcell = Worksheets("test2").Range("A1")
Do While Not IsEmpty(firstCell)
Set firstCell = currentcell
Do While Not IsEmpty(currentcell)
Set nextcell = currentcell.Offset(1, 0)
If IsEmpty(nextcell) Then
Range(firstCell.Address, currentcell.Address).Select
Selection.Rows.group
Set currentcell = nextcell.Offset(1, 0)
Set firstCell = nextcell.Offset(1, 0)
Else
Set currentcell = nextcell
End If
Loop
Loop
End Sub
First of all, your code goes wrong when it says
Range("firstCell:currentCell").Select
You are trying to select the range named "firstCell:currentCell" instead of
selecting range from first Cell to currentCell
You should change it to
.Range(firstCell,currentCell).select
Try using below code and see if it does what you want it to do
Dim GROUP_LAST_CELL As Range
With Worksheets("627")
LAST_ROW = .Range("A" & Rows.Count).End(xlUp).Row
I = 1
While I <= LAST_ROW
Set GROUP_LAST_CELL = .Cells(I, 1).End(xlDown)
.Range(.Cells(I, 1), GROUP_LAST_CELL).Rows.Group
I = GROUP_LAST_CELL.Row + 2
Wend
End With
According to what i understood from the question, i think what you want to do is to loop across all the elements in a particular column, skipping all the blanks.
You can do so by
Calculating the lastrow of the column
Looping across from the first row count to the calculated lastRow count
Applying a condition within the loop to only print the non-empty cells
Code Block
Sub test()
Dim j As Long, lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To lastRow
If Cells(j, "A").Value <> "" Then
MsgBox (Cells(j, "A").Value)
End If
Next j
End Sub
I Hope this helped!
I am trying to write code to copy certain ranges of data from each sheet to a summary sheet. I have attempted many versions of this (far too many for me to put them all here), but with each one the summary sheet has empty values. I don't understand what is going wrong, and I have no theories.
Here is the version that I wrote myself. All of the other variations I tried were found on the Internet:
Note: The actual summary sheet is created elsewhere in code. Also, the reason why I have sheetIndex starting at 6 is because that's the first sheet I want to take data from.
Sub PopulateSummary()
Dim nmbrParts As Integer
Dim partIndex As Integer
Dim sheetIndex As Integer
Dim sheetCount As Integer
sheetCount = ThisWorkbook.Sheets.Count
for sheetIndex = 6 To sheetCount
With Sheets(sheetIndex)
.Activate
.Range("B2").Select
Call SelectFirstToLastInColumn
nmbrParts = Selection.Count
Sheets("Summary").Activate
for partIndex = 1 To nmbrParts
row = partIndex + 1
Sheets("Summary").Cells(row, 1).Value = .Cells(row, 1).Value
Sheets("Summary").Cells(row, 2).Value = .Cells(row, 2).Value
Sheets("Summary").Cells(row, 3).Value = .Cells(row, 4).Value
Sheets("Summary").Cells(row, 3).Value = .Cells(row, 3).Value
Sheets("Summary").Cells(row, 5).Value = .Cells(row, 6).Value
Next partIndex
End With
Next sheetIndex
End Sub
EDIT: I figured something out. Since I'm invoking these macros from another workbook, I changed ThisWorkbook to ActiveWorkbook, so it counts the right number of sheets. The problem isn't solved, though.
Break it into pieces and step through the code one line at a time. That will tell you whether you're selecting what you think you're selecting, whether row is what you think it is, etc. Also, pause when the code hits your first Sheets("Summary").Cells... line and use the Immediate Window (Ctrl+G) to output the value of your destination cell with
?.Cells(row, 1).Value
Also, since you've got a With block, you don't really need to activate and select cells (and you shouldn't select most of the time in VBA anyway, as doing stuff in the sheet is slow), and you also don't have to activate Sheets("Summary") since you're referencing it directly. You could do something like:
With Sheets(sheetIndex)
nmbrParts = .Range("B:B").Find(what:="*",searchDirection:=xlPrevious).Row
for ...
.
.
.
End With
The simpler and shorter the code, the easier it is to test.
I figured it out....
I was having some problem with variable names being in the wrong place. My macro SHOULD look
something like this:
Sub PopulateSummary()
Dim nmbrParts As Integer
Dim partIndex As Integer
Dim sheetIndex As Integer
Dim sheetCount As Integer
Dim row As Integer
row = 2
sheetCount = ActiveWorkbook.Sheets.Count
For sheetIndex = 6 To sheetCount
With Sheets(sheetIndex)
.Activate
.Range("B2").Select
nmbrParts = .Range("B:B").Find(what:="*", searchDirection:=xlPrevious).row
For partIndex = 1 To nmbrParts
destRow = partIndex + 1
Sheets("Summary").Cells(row, 1).Value = .Cells(destRow, 1).Value
Sheets("Summary").Cells(row, 2).Value = .Cells(destRow, 2).Value
Sheets("Summary").Cells(row, 3).Value = .Cells(destRow, 4).Value
Sheets("Summary").Cells(row, 4).Value = .Cells(destRow, 3).Value
Sheets("Summary").Cells(row, 5).Value = .Cells(destRow, 6).Value
row = row + 1
Next partIndex
End With
Next sheetIndex
End Sub
The difference is that I used a different name to refer to rows on the sheets that I was taking from. So, I would be able to keep the numbers separate. I also found an error that I had mentioned in my Edit where I had to change ThisWorkbook to ActiveWorkbook so the sheet count could be correct.
Thanks to redOctober13 for the testing advice. You've taught me the importance of using the debugger.
i'm trying to make a macro which:
goes through a table
looks if value in column B of that table has a certain value
if it has, copy that row to a range in an other worksheet
The result is similar to filtering the table but I want to avoid hiding any rows
I'm kinda new to vba and don't really know where to start with this, any help much appreciated.
That is exactly what you do with an advanced filter. If it's a one shot, you don't even need a macro, it is available in the Data menu.
Sheets("Sheet1").Range("A1:D17").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("G1:G2"), CopyToRange:=Range("A1:D1") _
, Unique:=False
Try it like this:
Sub testIt()
Dim r As Long, endRow as Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
Selects are slow and unnescsaary. The following code will be far faster:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
For i = 2 To ws1.Range("B65536").End(xlUp).Row
If ws1.Cells(i, 2) = "Your Critera" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
Next i
End Sub
you are describing a Problem, which I would try to solve with the VLOOKUP function rather than using VBA.
You should always consider a non-vba solution first.
Here are some application examples of VLOOKUP (or SVERWEIS in German, as i know it):
http://www.youtube.com/watch?v=RCLUM0UMLXo
http://office.microsoft.com/en-us/excel-help/vlookup-HP005209335.aspx
If you have to make it as a macro, you could use VLOOKUP as an application function - a quick solution with slow performance - or you will have to make a simillar function yourself.
If it has to be the latter, then there is need for more details on your specification, regarding performance questions.
You could copy any range to an array, loop through this array and check for your value, then copy this value to any other range. This is how i would solve this as a vba-function.
This would look something like that:
Public Sub CopyFilter()
Dim wks As Worksheet
Dim avarTemp() As Variant
'go through each worksheet
For Each wks In ThisWorkbook.Worksheets
avarTemp = wks.UsedRange
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
'check in the first column in each row
If avarTemp(i, LBound(avarTemp, 2)) = "XYZ" Then
'copy cell
targetWks.Cells(1, 1) = avarTemp(i, LBound(avarTemp, 2))
End If
Next i
Next wks
End Sub
Ok, now i have something nice which could come in handy for myself:
Public Function FILTER(ByRef rng As Range, ByRef lngIndex As Long) As Variant
Dim avarTemp() As Variant
Dim avarResult() As Variant
Dim i As Long
avarTemp = rng
ReDim avarResult(0)
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
If avarTemp(i, 1) = "active" Then
avarResult(UBound(avarResult)) = avarTemp(i, lngIndex)
'expand our result array
ReDim Preserve avarResult(UBound(avarResult) + 1)
End If
Next i
FILTER = avarResult
End Function
You can use it in your Worksheet like this =FILTER(Tabelle1!A:C;2) or with =INDEX(FILTER(Tabelle1!A:C;2);3) to specify the result row. I am sure someone could extend this to include the index functionality into FILTER or knows how to return a range like object - maybe I could too, but not today ;)