I am working on a macro for copying rows for different locations to sheets specific to the locations from a master sheet.
I have everything working except finding the last row when the cell I am checking contains a '0' and shows as an empty string match. I need to either find a better way to paste to the first empty row, or to find out if the cell being checked is truly empty.
Here is the macro code:
Sub MoveDataToSheets()
'
' MoveDataToSheets Macro
' Macro written 2/25/2011 by Jim Snyder
'
Dim rowCount As Integer, sheetIndex As Integer, LastRow As Integer
Dim ExcelLastCell As Range
' Prevent screen updates from slowing execution
Application.ScreenUpdating = False
rowCount = ActiveCell.CurrentRegion.Rows.Count
' Process each row once copying row to matching location tab
For currentRow = 1 To rowCount
' Determine which sheet the row goes to
Select Case (Cells(currentRow, "B").Value)
Case "ALTAVISTA"
sheetIndex = 2
Case "AN"
sheetIndex = 3
Case "Ballytivnan"
sheetIndex = 4
Case "Casa Grande"
sheetIndex = 5
Case "Columbus - Devices (DE)"
sheetIndex = 6
Case "Columbus - Nutrition"
sheetIndex = 7
Case "Fairfield"
sheetIndex = 8
Case "Granada"
sheetIndex = 9
Case "Guangzhou"
sheetIndex = 10
Case "NOLA"
sheetIndex = 11
Case "Process Research Operations (PRO)"
sheetIndex = 12
Case "Richmond"
sheetIndex = 13
Case "Singapore"
sheetIndex = 14
Case "Sturgis"
sheetIndex = 15
Case "Zwolle"
sheetIndex = 16
Case Else
sheetIndex = 1
End Select
' Only if the row cotains a valid location, copy it to location sheet
If (sheetIndex > 1) Then
Sheets(1).Activate ' Activate the sheet being copied from
ActiveSheet.Rows(currentRow).Copy ' Copy from master sheet
Set sheet = Worksheets(sheetIndex) ' Designate target sheet
Set ExcelLastCell = sheet.Cells.SpecialCells(xlLastCell) ' Find the last used row
LastRow = ExcelLastCell.Row
If (sheet.Rows(LastRow).Cells(LastRow, 5).Value = "") Then
sheet.Paste Destination:=sheet.Cells(LastRow, 1) ' Paste into first row
Else
sheet.Paste Destination:=sheet.Cells(LastRow + 1, 1) ' Paste in first empty row
End If
Sheets(1).Activate ' Activate the sheet being copied from
End If
Next
Application.ScreenUpdating = True
End Sub
Chip Pearson's site has an example of what you need. You can do this on each page prior to paste.
Finding The Last Used Cell In A Range
Assuming your using Excel 2003 and/or you won't have more than 65,536 on any sheet:
LastRow = Sheet.Range("A65536").End(xlUp).Row
For just finding the last cell that has a value in a column:
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
You can then use LastRow as a standard row reference. I often use it to find the last row then add 1, which actually gives me the first empty cell in that column. Example:
Cells(LastRow + 1, 6).Value = Cells(10, 3).Value 'Or whatever value you want
The CPearson site linked above by datatoo however does list many more ways to find "last cells" if you are looking for more complicated solutions.
Edit: Just tested to be sure: this does detect 0s or nulls ( ="" ) in the column.
Related
I'm trying to copy rows from a significant amount of worksheets.
I have multiple lines that relate to a certain document, depending on the versions.
Therefore, some lines have the same reference, same name but a different version/date of creation. I'd like to copy to another sheet (Sheet2 for instance) the latest version of every document.
I've tried so far with a few while loops to check all lines and a if to check the value of the date but I failed to make it work, and I wonder if it's an efficient way of doing it.
Here is a picture of my problem and a part of the code I wrote :
Dim Name as String
Dim Dates as Date
With Sheets(Sheet1)
Application.DisplayAlerts = False
Name = Cells(1,3) 'Initialise Name
Dates = Cells(1,5) 'Initialise Dates
LineCopy = 1 'The line we'll copy
Line = 1 'The line we use to check the sheet
While Name <> "" 'if the name is not empty, ie there are no documents left
While Sheets(Sheet1).StrComp(Name, .Cells(Line, 3)) = True 'WHile you are working with a same name document
If .Cells(Line, 5) > Dates Then 'If the document is older, then choose it.
Dates = .Cells(Line, 5)
Else
LineCopy = Line 'If there are no older documents, then it's the one to copy
Sheets(Sheet1).Range("A" & LineCopy & ":" & "E" & LineCopy).Copy ' Copy the oldest document
Sheets(Sheet2).Paste
End If
Line = Line + 1 ' Increment the Line in the second while to check every line
Wend
Name = .Cells(LineCopy + 1, 6) 'After the first while, let's change name to the second document and do it all over again.
Wend
Unless you need the formating I think copy and paste should be avoided.
The below code assumes the data is sorted on column A. If not another aproach is needed.
Edit: Adapted to comment that there may be blank rows.
Dim max_date As Date
Dim max_row As Long
Dim old_sheet As Worksheet
Dim new_sheet As Worksheet
Dim counter As Long
Dim last_name as String
Set new_sheet = Sheets("Sheet2") 'adjust name to result sheet
counter = 1
For x = 1 To 5 ' the sheets you should loop thru
Set old_sheet = Sheets(x)
end_row = old_sheet.Cells(old_sheet.Rows.Count, 1).End(xlUp).Row
For i = 2 To end_row 'loop all rows
If old_sheet.Cells(i, 5) > max_date Then 'if the date is larger, sve the date and the row
max_date = old_sheet.Cells(i, 5)
max_row = i
End If
if old_sheet.cells(i,j)<>"" then last_name = old_sheet.cells(i,j)
If (old_sheet.Cells(i + 1, 1) <> "" and old_sheet.Cells(i + 1, 1) <> last_name) or i = end_row Then
For j = 1 To 4
new_sheet(counter, j) = old_sheet(max_row, j) 'add the data to the new sheet
Next j
max_date = DateValue("01/01/1970") 'reset the date value
counter = counter + 1 'new row to move the data to
End If
Next i
Next x
I am creating a macro to help organize a data dump (sheet 1) into an invoice (sheet 2). I have coded most of the macro, but am stuck on the following.
I want the macro to read column Y on sheet 1, which is a variable range (can be 2 rows to 50) and check if it says "CB". If this is true, then E11 on sheet 2 is Yes, otherwise No, and so on until it reaches the end of column Y on sheet 1.
I have the following:
Sheets("Data_Dump").Select
intCounter = 1
While Range("Y" & (intCounter + 1)) <> ""
intCounter = intCounter + 1
Wend
intCardSize = intCounter
MsgBox (intCardSize)
Sheets("Data_Dump").Select
If Range("Y" & intCardSize) = "CB" Then
Sheets("Reconciliation").Select
Range("E11:E" & intCardSize).Select
Range("E11") = "Yes"
End If
The while range seems to work and it displays the number of cells with text in column Y, but I can't seem to wrap my head around how to get it to move from Y1 to Y2 and so on and then paste the response into E11 then E12 and so on.
The problem that you are having is that your code doesn't loop to try to compare. The While loop that you have only looks to see if there is something in the next cell. In fact, it actually skips the first row, but maybe that was intentional.
Dim dataSheet As WorkSheet
Dim recSheet As Worksheet
Dim lngCounter As Long 'Use long because an integer may not be big enough for large dataset.
Dim intCardSize As Long
Set dataSheet = ThisWorkbook.Sheets("Data_Dump")
Set recSheet = ThisWorkbook.Sheets("Reconciliation")
'You want to set the sheets to a variable instead of referring to the whole path each time
'Also, Note the usage of "ThisWorkbook" which guarantees the worksheet
'is coming from the one with code in it.
lngCounter = 2 'If you want to start looking at row 2, start at row 2 with
'the variable instead of starting the variable and checking var+1
While dataSheet.Range("Y" & (lngCounter)) <> ""
'While there is a value in the column
'intCardSize = intCounter 'Not sure what this is supposed to do
'MsgBox (intCardSize) 'This looks like debugging. Commenting out.
If dataSheet.Range("Y" & lngCounter) = "CB" Then
'Check each row as you go through the loop.
'Sheets("Reconciliation").Select
'Avoid selecting sheet/range. Unneccessary work for computer.
recSheet.Range("E" & (9 + lngCounter)) = "Yes"
'Set reconciliation sheet value to "Yes" if data sheet has "CB"
'The reconciliation sheet starts on row 11, whereas the datasheet
'starts at row 2 ,a difference of 9
Else
recSheet.Range("E" & (9 + lngCounter)) = "No"
'Otherwise set to no.
End If
lngCounter = lngCounter + 1
Wend
intCardSize = lngCounter - 1 'It's been increased to one past the last item.
MsgBox intCardSize 'Display the last row checked.
I hope I understood your code goal as follows
With Sheets("Data_Dump")
With Sheets("Reconciliation").Range("E11").Resize(.Cells(.Rows.Count,1).Row)
.Formula="=IF('Data_Dump'!Y1="CB", "Yes","")"
.Value= .Value
End With
End With
This Question has been answered, however I need help with one point. I am using the code provided in the answer, however I can not get the subgrouping, for the entirety of the document. Is such thing possible?
Section Index
1 1
+ 1.1 2
++ 1.1.1 3
+++1.1.1.1 4
+++1.1.1.2 4
+++1.1.1.3 4
++ 1.1.2 3
++ 1.1.3 3
+ 1.2 2
+ 1.3 2
2 1
NOTE: Plusses shows groups.
I have such table as above, where I have indexed the sections with sublevels. I am trying to group those section using excel group feature, however, I have over 3000 rows of data, so I am trying to automate the process. I have modified a Excel VBA macro I found here and got this code below.
Sub AutoGroupBOM()
'Define Variables
Dim StartCell As Range 'This defines the highest level of assembly, usually 1, and must be the top leftmost cell of concern for outlining, its our starting point for grouping'
Dim StartRow As Integer 'This defines the starting row to beging grouping, based on the row we define from StartCell'
Dim LevelCol As Integer 'This is the column that defines the assembly level we're basing our grouping on'
Dim LastRow As Integer 'This is the last row in the sheet that contains information we're grouping'
Dim CurrentLevel As Integer 'iterative counter'
Dim groupBegin, groupEnd As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer
Application.ScreenUpdating = False 'Turns off screen updating while running.
'Prompts user to select the starting row. It MUST be the highest level of assembly and also the top left cell of the range you want to group/outline"
Set StartCell = Application.InputBox("Select levels' column top cell", Type:=8)
StartRow = StartCell.Row
LevelCol = StartCell.Column
LastRow = ActiveSheet.UsedRange.End(xlDown).Row 'empty rows above aren't included in UsedRange.rows.count => UsedRange.End
'Remove any pre-existing outlining on worksheet, or you're gonna have 99 problems and an outline ain't 1
Cells.ClearOutline
'Walk down the bom lines and group items until you reach the end of populated cells in the assembly level column
groupBegin = StartRow + 1 'For the first group
For i = StartRow To LastRow
CurrentLevel = Cells(i, LevelCol)
groupBegin = i + 1
'Goes down until the entire subrange is selected according to the index
For n = i + 1 To LastRow
If Cells(i, LevelCol).Value = Cells(n, LevelCol).Value Then
If n - i = 1 Then
Exit For
Else
groupEnd = n - 1
Rows(groupBegin & ":" & groupEnd).Select
'If is here to prevent grouping level that have only one row
End If
Exit For
Else
End If
Next n
Next i
'For last group
Rows(groupBegin & ":" & LastRow).Select
Selection.Rows.Group
ActiveSheet.Outline.ShowLevels RowLevels:=1 'Minimize all the groups
ActiveSheet.Outline.SummaryRow = xlAbove 'Put "+" next to first line of each group instead of the bottom
Application.ScreenUpdating = True 'Turns on screen updating when done.
End Sub
Basically what I am trying to do in the above code is to select the top index and run down the cells until that index is the same value again. Basically for the example chart, I would like to select rows(2:4) and group them. This is not achieved by the code. Also, code skips grouping if the adjacent rows are with the same index.
Is this a viable method or should I re-think my loops and how?
The code you have arrived at seems a little convoluted to me. Change to your needs and try this:
Sub groupTest()
Dim sRng As Range, eRng As Range ' Start range, end range
Dim rng As Range
Dim currRng As Range
Set currRng = Range("B1")
Do While currRng.Value <> ""
Debug.Print currRng.Address
If sRng Is Nothing Then
' If start-range is empty, set start-range to current range
Set sRng = currRng
Else
' Start-range not empty
' If current range and start range match, we've reached the same index & need to terminate
If currRng.Value <> sRng.Value Then
Set eRng = currRng
End If
If currRng.Value = sRng.Value Or currRng.Offset(1).Value = "" Then
Set rng = Range(sRng.Offset(1), eRng)
rng.EntireRow.Group
Set sRng = currRng
Set eRng = Nothing
End If
End If
Set currRng = currRng.Offset(1)
Loop
End Sub
Note that there is no error-handling here, the code is a little verbose for readability and bonus - no select.
Edit:
As requested, the subgrouping. This actually had me stuck for a bit - I coded myself into a corner and only barely got out on my own!
A few notes:
I have tested this to some extent (with 4 sublevels and multiple parents) and it works nicely. I tried to write the code so that you can have as many sublevels or as many parents as you want. But it has not been extensively tested, so I couldn't guarantee anything.
However, for some scenarios, Excel won't properly display the +-signs, I am guessing that is due to lack of space in these particular scenarios. If you encounter this, you can contract and expand the different levels using the numbered buttons at the top of the column the +-signs are located in. This will expand/contract all groups of that particular sub-level, however, so it is not optimal. But it is what it is.
Assuming a setup like this (this is after the grouping - you can see the missing +-signs here, for example for group 1.3 and 3.1 -- but they are grouped!):
Sub subGroupTest()
Dim sRng As Range, eRng As Range
Dim groupMap() As Variant
Dim subGrp As Integer, i As Integer, j As Integer
Dim startRow As Range, lastRow As Range
Dim startGrp As Range, lastGrp As Range
ReDim groupMap(1 To 2, 1 To 1)
subGrp = 0
i = 0
Set startRow = Range("A1")
' Create a map of the groups with their cell addresses and an index of the lowest subgrouping
Do While (startRow.Offset(i).Value <> "")
groupMap(1, i + 1) = startRow.Offset(i).Address
groupMap(2, i + 1) = UBound(Split(startRow.Offset(i).Value, "."))
If subGrp < groupMap(2, i + 1) Then subGrp = groupMap(2, i + 1)
ReDim Preserve groupMap(1 To 2, 1 To (i + 2))
Set lastRow = Range(groupMap(1, i + 1))
i = i + 1
Loop
' Destroy already existing groups, otherwise we get errors
On Error Resume Next
For k = 1 To 10
Rows(startRow.Row & ":" & lastRow.Row).EntireRow.Ungroup
Next k
On Error GoTo 0
' Create the groups
' We do them by levels in descending order, ie. all groups with an index of 3 are grouped individually before we move to index 2
Do While (subGrp > 0)
For j = LBound(groupMap, 2) To UBound(groupMap, 2)
If groupMap(2, j) >= CStr(subGrp) Then
' If current value in the map matches the current group index
' Update group range references
If startGrp Is Nothing Then
Set startGrp = Range(groupMap(1, j))
End If
Set lastGrp = Range(groupMap(1, j))
Else
' If/when we reach this loop, it means we've reached the end of a subgroup
' Create the group we found in the previous loops
If Not startGrp Is Nothing And Not lastGrp Is Nothing Then Range(startGrp, lastGrp).EntireRow.Group
' Then, reset the group ranges so they're ready for the next group we encounter
If Not startGrp Is Nothing Then Set startGrp = Nothing
If Not lastGrp Is Nothing Then Set lastGrp = Nothing
End If
Next j
' Decrement the index
subGrp = subGrp - 1
Loop
End Sub
The subGroupTest() function above can be replaced by 6 lines of code:
Sub subGroupTest()
Dim cRng As range
Set cRng = range("A1")
Do While cRng.Value <> ""
cRng.EntireRow.OutlineLevel = UBound(Split(cRng.Value, ".")) + 1
Set cRng = cRng.Offset(1)
Loop
End Sub
Consecutive rows on the same OutlineLevel are automatically grouped together, so no need to jump through all the hoops in order to solve for the depths manually. OutlineLevel = 1 means the row is not grouped too.
As a bonus, there is no need to delete the outline levels beforehand.
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
I have a code that reads in the new arrangement of columns from a text file and then rearrange the original columns by copying it in at the correct place, however there is a bug in my code. Instead of copying just 1 column it seems to copy all columns to the right of the column that i want to copy..
so i guess the error is here
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead? If i do so the stuff in row 1 will be deleted, below is the full code:
Sub insertColumns()
Call Settings.init
Dim i As Integer
Dim ws As Worksheet
Dim lrow As Integer
Dim columNames As Object
Dim temp As Variant
'fill dictionary with columnnames from text file
Set columNames = FileHandling.getTypes(Settings.columnFile)
Set ws = ActiveWorkbook.Sheets("List")
'Get max column and row number
lColumn = HelpFunctions.getLastColumn(ws, Settings.rowHeader)
lrow = HelpFunctions.getLastRow(ws, HelpFunctions.getColumn("*part*", ws, Settings.rowHeader))
'Insert all new columns in reverse order from dictionary
temp = columNames.keys
For i = columNames.Count - 1 To 0 Step -1
ws.Columns("A:A").Insert Shift:=xlToRight
ws.Range("A" & Settings.rowHeader).Value = temp(i)
Next i
'last column
lastColumn = lColumn + columNames.Count
'we loop through old cells
CounterCol = columNames.Count + 1
Do While CounterCol <= lastColumn
j = 0
'through each elemnt in dictionary
For Each element In temp
j = j + 1
'compare the old rowheader with any of the rowheader in DICTIONARY
If UCase(ws.Cells(Settings.rowHeader, CounterCol).Value) = element Then
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
'paste it
ws.Cells(Settings.rowHeader + 1, j).Select
ws.Paste
'format the new row
ws.Cells(Settings.rowHeader + 1, j).EntireColumn.AutoFit
'Delete the old row
ws.Columns(CounterCol).EntireColumn.Delete
'decrease the last column by one since we just deleted the last column
lastColumn = lastColumn - 1
found = True
'Exit For
End If
Next element
'Prompt the user that the old column does not match any of the new column
If Not found Then
MsgBox (UCase(ws.Cells(Settings.rowHeader, CounterCol)) & " was not a valid column name please move manually")
End If
'reset the found
found = False
'go to nect column
CounterCol = CounterCol + 1
Loop
End Sub
Below is a screenshot of the dictionary.
After the first iteration/first copy it should have only copied over the part number column, but as can been seen it has copied over more than just the first column(everything except of drawing number)
Q: I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead?
A: No. Any range can be copied.
Rather than trying to debug your code, I'll give you a hint about how to debug such a thing. Lines like
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
are hard to debug because they are trying to do too much. You have 4 instances of the dot operator and suspected that the problem was with the last one (.Copy). The problem is almost certainly that your code isn't grabbing the range that you think it is grabbing. In other words, one or more of your method invocations earlier in the line needs debugging. In such a situation it is useful to introduce some range variables, set them equal to various values and print their addresses to the immediate window to see what is happening. As an added benefit, having set range variables allows you to use the full power of intellisence in the VBA editor. Something like:
Dim SourceRange As Range, Cell1 As Range, Cell2 As Range
'
'
'
Set Cell1 = ws.Cells(Settings.rowHeader + 1, CounterCol)
Set Cell2 = ws.Cells(lrow, CounterCol)
Set SourceRange = ws.Range(Cell1, Cell2)
Debug.Print Cell1.Address & ", " & Cell2.Address & ", " & SourceRange.Address
'
'Once the above is debugged:
'
SourceRange.Copy 'should work as expected
It is possible that you are copying the range that you want to copy but that your larger program still isn't working. In that case you have some sort of logic error and should be trying to copy some other range. Even then, the above exercise still helps because it makes it clear exactly what your original line was doing.
'go to nect column
CounterCol = CounterCol + 1
needed to be deleted. It has to do that the column shifts left when i deleted rows.
Thanks for the help. I hope the code can be used for others who might need to add columns, but still copy over content from old columnsin the right order.