Copy rows between two values VBA and paste to new sheet loop - excel

I am trying to figure out some code here, I have looked on a few sites now, including here and it almost works but it is most likely my datasheet that is causing the issue.
This: Search for two values and copy everything in between in a loop
and this: I need code to copy between two rows and paste into the another sheet with our giving any values?
Would probably work, however the first value cannot be found. Let me explain.
I have an exported report from a website, it groups the totals with a name (value 1) and then the word totals for: (word 2).
What I need it to do is only copy and paste where value 1 is met , and value 2 will always be "totals for:".
Problem is with this loop is that there are blanks between each group of data, so it finds the first "totals for:" but cannot find my first value because it is between about 20 blank cells. (19 groups of data - with a blank row between each group).
How can i retro fix the above codes so that it keeps going down the rows, regardless of blanks to find the first value, then find the second value. Copy that range to a new sheet, and repeat this with a new value 1?
Sub MoveRows()
Dim rownum As Integer
Dim colnum As Integer
Dim startrow As Integer
Dim endrow As Integer
rownum = 1
colnum = 1
With ActiveWorkbook.Worksheets("Sheet1")
Do
If .Cells(rownum, 1).Value = "LIFEC - Supp Life - Ch" Then
startrow = rownum
End If
rownum = rownum + 1
Loop Until .Cells(rownum, 1).Value = "Totals for:"
endrow = rownum
ActiveWorkbook.Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
End With
ActiveWorkbook.Worksheets("Sheet2").Paste
End Sub
Sub Star123()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "LIFEC - Supp Life - Ch" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "Totals for:"
endrow = rownum
rownum = rownum + 1
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
I attached the codes that almost work, but cannot find my first value.

You can use Find method which looks something like:
Dim s As Range, e As Range
With Sheet1 'or this can be any other sheet where you search
Set r = .Range("A:A").Find("Whatever you want found")
If Not r Is Nothing Then
Set e = .Range("A:A").Find("The other end", r)
If Not e Is Nothing Then
.Range(r, e).EntireRow.Copy Sheet2.Range("A1") 'or to whatever sheet
End If
End If
End With
You can then have this in a loop which replaces the strings you want found. HTH.

Related

combine 2 if statements

In my vba code below I am trying to delete to specific colors from a row. Right now I would like to combine 2 if statements into 1 if statement. Right now my code below is working but is inefficient if more colors are added. Look for the if statements regarding blue and red for this problem.
Sub collapse_columns()
Dim x As Integer
For x = 1 To 4
collapse_column x
Next
End Sub
Sub collapse_column(column_number As Integer)
Dim row As Long
Dim s As Worksheet
Dim last_row As Long
Set s = ActiveSheet ' work on the active sheet
'Set s = Worksheets("Sheet1") 'work on a specific sheet
last_row = ActiveSheet.Cells(s.Rows.Count, column_number).End(xlUp).row
For row = last_row To 1 Step -1
If Cells(row, column_number).Value = "red" Then Cells(row, column_number).Delete xlUp
Next
For row = last_row To 1 Step -1
If Cells(row, column_number).Value = "blue" Then Cells(row, column_number).Delete xlUp
Next
End Sub
When I have many possible values that can trigger the same code, I like to use a string to hold the values, then search the string to find a match as follows:
Sub collapse_column(column_number As Integer)
Dim row As Long
Dim s As Worksheet
Dim last_row As Long
Set s = ActiveSheet ' work on the active sheet
'Set s = Worksheets("Sheet1") 'work on a specific sheet
last_row = ActiveSheet.Cells(s.Rows.Count, column_number).End(xlUp).row
Dim colors_to_delete As String
colors_to_delete = ",red,blue," ' be sure to keep the leading and trailing commas
For row = last_row To 1 Step -1
If InStr(1, colors_to_delete, "," & Cells(row, column_number).Value & ",") > 0 Then Cells(row, column_number).Delete xlUp
Next
End Sub

How to auto number till merge cell is detected?

My knowledge in VBA coding is zero. I wonder if someone can help with this question, please.
I have this initial code tried to write but it is wrong. I was not sure how to add these below conditions in the code.
Question: I want to auto number column A which starts at a specific Cell, A3 and it auto-numbers as long as there is text in Column B and Column C.
Here's the sample data picture. Thanks in advance!
Sub test()
Set r = Range("a3", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
With r
If .MergeCells <> True Then
r = r +1
Else
' Skip
End With
End Sub
Assuming your sheet is named Sheet1, you may use something like this:
Sub Test()
Dim lastRow As Long, i As Long, counter As Long
With Sheet1
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Not IsEmpty(.Cells(i, 2)) And Not IsEmpty(.Cells(i, 3)) Then
counter = counter + 1
.Cells(i, 1).Value = counter
End If
Next
End With
End Sub
Note: Using IsEmpty to check if any of the cells in columns B & C is empty already covers the case of cells being merged because in that case, at least one of the two cells has to be empty anyway.
Demo:
You have r as a range, you can't add a number to it and have it increment the range. (Though I did just test it and it doesn't throw an error which is strange)
Also Skip is not a thing in VBA, if you want to skip in a loop you need a conditional or a goto. Though you have no loop.
Sub test()
Dim i As Long
Dim lastrow As Long
Dim counter As Long
counter = 1
With ActiveSheet ' Change this to the real sheet name
lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row ' Gets Last row
For i = 3 To lastrow ' Loop
If not isempty(.Cells(i, 2).Value) And not IsEmpty(.Cells(i, 3).Value) Then ' Looks for Text
If Not .Cells(i, 1).MergeCells Then ' Looks for merged cells
.Cells(i, 1).Value = counter ' Adds count
counter = counter + 1 ' Increments count
End If
End If
Next i
End With
See for comments and customize to fit your needs:
Public Sub AutoNumber()
' Declare objects
Dim evalRange As Range
Dim evalCell As Range
' Declare other variables
Dim sheetName As String
Dim initialCellAddress As String
Dim lastRow As Long
Dim columnNumber As Long
Dim counter As Long
' Customize to fit your needs
sheetName = "Sheet1"
initialCellAddress = "B2"
counter = 1
' Get column number and last row number to define the range address ahead
columnNumber = Range(initialCellAddress).Column
lastRow = ThisWorkbook.Worksheets(sheetName).Cells(Rows.Count, columnNumber).End(xlUp).Row
' Define the range to be evaluated
Set evalRange = ThisWorkbook.Worksheets(sheetName).Range(initialCellAddress & ":" & Left$(initialCellAddress, 1) & lastRow)
' Loop through each cell in range (in the original example we'll loop through column b)
For Each evalCell In evalRange
If evalCell.MergeCells <> True Then
' Assign the counter to the column at the left (offset = -1) of the evaluated cell
evalCell.Offset(rowoffset:=0, columnOffset:=-1).Value2 = counter
counter = counter + 1
End If
Next evalCell
End Sub

VBA VLOOKUP with dynamic range

I am brand-new to VBA.
I have two worksheets in the same workbook. The first worksheet, shStudentInfo, contains all of the information for each of my students, one row per StudentID (B4 in the code). The second worksheet, shSchedData, contains their schedules where there may be 0-14 rows per StudentID, depending on how many courses each student is taking.
I am attempting to use a loop and VLOOKUP with a dynamic range to extract the course name from each row of shSchedData and copy it to the appropriate cell in shStudentInfo, then move down one row. Currently I've hardcoded cell "CO4" as the appropriate cell although I will also need to make that reference move one cell to the right for each pass through the loop.
Here is my inelegant code:
Option Explicit
Dim MyRow As Long
Sub StudentSchedules()
Dim EndRow As Long
Dim MyRng As Range
shSchedData.Activate
'hard code first row of data set
MyRow = 3
'dynamic code last row of data set
EndRow = shSchedData.Range("A1048575").End(xlUp).Row
'create a dynamic range, a single row from shSchedData
Set MyRng = ActiveSheet.Range(Cells(MyRow, 1), Cells(MyRow, 9))
'Loop through entire data set one line at a time
Do While MyRow <= EndRow
shSchedData.Select
MyRng = ActiveSheet.Range(Cells(MyRow,1),Cells(MyRow,9))
shStudentInfo.Select
'Import course name from shSchedData worksheet
Range("CO4").Select
ActiveCell.Clear
ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng,6,0)"
'The above line results in a #NAME? error in CO4 of shStudentInfo
'Also tried:
'ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng.Address,6,0)"
'increment counter
MyRow = MyRow + 1
Loop
End Sub
The following rewrite will get your code working to the extent that its purpose can be determined.
The VLOOKUP formula does not appear correct and in any event, there might be a better method of retrieving the data. However, I cannot determine your end purpose from your narrative or code. Sample data together with expected results would help.
Option Explicit
'I see no reason to put this here
'dim myRow As Long
Sub StudentSchedules()
Dim myRow, endRow As Long, myRng As Range
'no need to activate, just With ... End With block it
With shSchedData
'assigned a strarting value
myRow = 3
'dynamic code last row of data set
endRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through entire data set one line at a time
Do While myRow <= endRow
'create a dynamic range, a single row from shSchedData
Set myRng = .Range(.Cells(myRow, 1), .Cells(myRow, 9))
'Import course name from shSchedData worksheet
shStudentInfo.Range("CO4").Offset(0, myRow - 3).Formula = _
"=VLOOKUP(B4, " & myRng.Address(external:=True) & ", 6, false)"
'increment counter
myRow = myRow + 1
Loop
End With
End Sub
I came up with this, see if it fits you
Dim a As Double
Dim b As Double
Dim ml As Worksheet
Dim arrayrng As Variant
Dim i As Integer
Dim x As String
Dim y As String
Set ml = Worksheets("Master Data")
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
For i = a To b - 1
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
arrayrng = "E" & a + 1
x = "=VLOOKUP(" & arrayrng
y = ",'Data Base'!I:J,2,0)"enter code here
Range("K" & a + 1) = x + y
Next

Excel - Move rows containing an empty cell to another sheet

This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy

Excel 2007 VBA runtime error when selecting worksheet with variable

I've been recently getting back into VBA and have been testing out a concept of Adding Worksheets by the string in a variable. I've been able to get the worksheets to add successfully and the last two lines of my code are simply to select the sheet name of the variable and then select cell A + the row number that is stored in another variable
In Sheet1, Column A, starting in A1, I have a list of 8 different names that cycles through:
Bob
Jeff
Max
Steve
Rosie
Pippa
Penelope
Rob
I am expecting the macro to end on Sheet "Rob" with cell A9 selected, however i get a runtime 1004 error
I have stepped through the code and it is selecting the sheet correctly with the variable, but when it tries to select row A9, the error presents
My code is below:
Sub Add_worksheets()
Dim sheetName As String
Dim rownum As Integer
rownum = 1
Range("A" & rownum).Select
sheetName = ActiveCell.Value
Do Until Range("A" & rownum).Value = ""
Range("A" & rownum).Select
sheetName = CStr(ActiveCell.Value)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
Sheets("sheet1").Select
rownum = rownum + 1
Loop
Sheets(sheetName).Select
Range("A" & rownum).Select
End Sub
Any help would be greatly appreciated
I also suggest you add if-else to check if the sheet name exists.. Why do you want to select? I do not support selections, since you need it you may try this: Because when you are incrementing rownum it goes to 10th cell, that means, Sheetname no longer has a name but empty..
Dim sheetName As String
Dim rownum As Integer
Dim WS as WorkSheet
rownum = 1
sheetName = Range("A" & rownum).Value '-- remove select
Do Until Range("A" & rownum).Value = ""
Range("A" & rownum).Select
sheetName = CStr(ActiveCell.Value)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
Set WS = Sheets(sheetName)
Sheets("sheet1").Select
rownum = rownum + 1
Loop
rownum = rownum - 1 '-- here
WS.Activate
Range("A" & rownum).Value = rownum
Or you may just use an array to do the creation of the sheets and then select a sheet later....Instead of going back and forth to first sheet...with names..
Sub addSheets()
Dim rowNum as Integer
Dim Ws as WorkSheet
Dim vArray as Variant
'-- creates one dimensional array
vArray = WorkSheetFunction.Transpoe(Sheets(1).Range("A1:A9"))
For rownum = Lbound(vArray) to Ubound(vArray)
If IsEmpty(vArray(rowNum)) Then
On Error Resume Next
Set Ws = Sheets(vArray(rowNum))
If Err.Number <> 0 Then '--no such sheet, so add it
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = vArray(rowNum)
Set Ws = Sheets(vArray(rowNum))
End If
End IF
Next rownum
Ws.Activate
Ws.Range("A1").offset(rownum).value = rownum
End Sub

Resources