I am trying to create an array where values come from the first row of a worksheet, then print those values in another sheet.
I tried to read the first row of Sheet2, store each value in the array until I hit an empty cell, then print that array in the first row of Sheet3.
I'm getting a application defined error in the while loop where I am making sure the row is not equal to Null.
Private Sub createFormatSheet()
With Worksheets("Sheet2")
Dim myTags() As Variant
Dim tag As Variant
Dim rw As Range
Dim i As Integer
i = 1
For Each rw In .Rows
While rw(i, 1) <> Null
myTags = Array(rw(i, 1))
i = i + 1
Wend
Next rw
End With
With Worksheets("Sheet3")
i = 1
For Each tag In myTag
.Cells(i, 1).Value = tag
Next tag
End With
End Sub
Here are two approaches:
Using an array (you don't need to loop through the items
Directly using ranges, no array involved
Step through the code using F8 and see what's going on
Private Sub createFormatSheet()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim startRow As Long
Dim endRow As Long
Dim values As Variant
Set sourceSheet = ThisWorkbook.Worksheets("Sheet2")
Set targetSheet = ThisWorkbook.Worksheets("Sheet3")
' Array approach (no need to loop) source = column 1
startRow = 1
endRow = sourceSheet.Cells(startRow, 1).End(xlDown).Row
values = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
' Target = column 1
targetSheet.Cells(startRow, 1).Resize(endRow, 1).Value = values
' Direct range target column 2
targetSheet.Cells(startRow, 2).Resize(endRow, 1).Value = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
End Sub
Let me know if it works
Related
I have tried to fix a code from the answers that I have found in the forum, but I can't manage.
My issue is:
I have a list of recipes names in the sheet weeks, and I want to decide with a 1 or a 0 which ones I want to meal prep for next week. In sheet Recipes, I have the Recipes listed with their ingredients list below. I would like to have an output of what I need to shop in Sheet 5.
In sheet Weeks If column B = 1, take recipe name in column A; Hlookup recipe name in sheet Recipes row 3, and return list of ingredients below to sheet 3 (the shopping list).
Sub Output_Shoopinglist()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Weeks")
Dim LastRow As Long ' get last used row in column b
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DataRange As Range ' get data range
Set DataRange = ws.Range("B3", "C20" & LastRow)
Dim DataArray() As Variant ' read data into an array (for fast processing)
DataArray = DataRange.Value
Dim OutputData As Collection ' create a collection where we collect all desired data
Set OutputData = New Collection
' check each data row and if desired add to collection
Dim iRow As Long
For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
If DataArray(iRow, 2) = 1 Then
OutputData.Add DataArray(iRow, 1)
End If
Next iRow
Dim wsTemplate As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets("Recipes")
Dim wsVolume As Worksheet
Set wsVolume = ThisWorkbook.Worksheets("Shopping list")
'Lookup Value in Tab Recipes in row 3, and return Ingrediants list one below the other in tab Shopping list in Column B
'Here I am missing code:
End Sub
Here are some screenshots:
I have left comments in few area to explain what the code is doing in general.
As mentioned in the comment - The basic idea is to perform a Find method along the row containing the recipe name and if it is found, the column number of the found cell will be used to pull out the list of ingredients (and the amount that is 1 column before) that is written below the recipe names.
Once the list has been retrieved in an array, it will be used to write into the shopping list worksheet at once.
Option Explicit
Const WSNAME_WEEK As String = "Weeks"
Const WSNAME_RECIPES As String = "Recipes"
Const WSNAME_SHOPPING As String = "Shopping list"
Sub Output_Shoppinglist()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets(WSNAME_WEEK)
Dim lastRow As Long ' get last used row in column b
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DataRange As Range ' get data range
Set DataRange = ws.Range("B4:C" & lastRow)
Dim DataArray() As Variant ' read data into an array (for fast processing)
DataArray = DataRange.Value
Dim OutputData As Collection ' create a collection where we collect all desired data
Set OutputData = New Collection
' check each data row and if desired add to collection
Dim iRow As Long
For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
If DataArray(iRow, 2) = 1 Then
OutputData.Add DataArray(iRow, 1)
End If
Next iRow
If OutputData.Count <> 0 Then
' Uncomment if you need to clear the shopping list prior to inserting this batch of list of ingredients
' With ThisWorkbook.Worksheets(WSNAME_SHOPPING)
' Dim shoppingLastRow As Long
' shoppingLastRow = .Cells(.Rows.Count, 2).Row
' .Range("A2:B" & shoppingLastRow).Value = ""
' End With
'1. Loop through the collection,
'2. Pass the recipe name to GetIngredients to retrieve the list of ingredients (in an array) from Recipes worksheet
'3. Pass the array to WriteToShoppingList for writing into the Shopping list worksheet
Dim i As Long
For i = 1 To OutputData.Count
'Get the ingredient list from Recipes sheet
Dim ingredList As Variant
ingredList = GetIngredients(OutputData(i))
If Not IsEmpty(ingredList) Then WriteToShoppingList ingredList
Next i
End If
MsgBox "Done!"
End Sub
Function GetIngredients(argRecipeName As String) As Variant
Const firstRow As Long = 7 'Change this to whichever row the first ingredient should be on
Const recipesNameRow As Long = 3
Dim wsTemplate As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets(WSNAME_RECIPES)
'==== Do a Find on row with the recipe names
Dim findCell As Range
Set findCell = wsTemplate.Rows(recipesNameRow).Find(argRecipeName, LookIn:=xlValues, LookAt:=xlWhole)
If Not findCell Is Nothing Then
'==== If found, assign the value of the ingredients (from firstRow to the last row) into an array
Dim lastRow As Long
lastRow = wsTemplate.Cells(firstRow, findCell.Column).End(xlDown).Row
Dim ingredRng As Range
Set ingredRng = wsTemplate.Range(wsTemplate.Cells(firstRow, findCell.Column), wsTemplate.Cells(lastRow, findCell.Column)).Offset(, -1).Resize(, 2)
Dim ingredList As Variant
ingredList = ingredRng.Value
GetIngredients = ingredList
End If
End Function
Sub WriteToShoppingList(argIngredients As Variant)
Dim wsVolume As Worksheet
Set wsVolume = ThisWorkbook.Worksheets(WSNAME_SHOPPING)
Dim lastRow As Long
lastRow = wsVolume.Cells(wsVolume.Rows.Count, 2).End(xlUp).Row
wsVolume.Cells(lastRow + 1, 1).Resize(UBound(argIngredients, 1), 2).Value = argIngredients
End Sub
There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?
Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*
It will be much appreciated if you help me get through this hard task
Thank you
You can use a For...Next loop for this:
Sub Tester()
Dim n As Long, c As Range
Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
'loop through sheets
For n = 2 To 23
'convert n to string to get the correct sheet
' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3")
c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
Set c = c.Offset(1, 0) 'next destination
End With
Next n
End Sub
You can do something like this:
Sub copyPaste()
Dim survey_sheet As Worksheet, count As Long
count = 1 'start pasting from this row
For Each survey_sheet In ThisWorkbook.Sheets
If survey_sheet.Name <> "ALL SURVEY" Then
survey_sheet.Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
count = count + 1
End If
Next survey_sheet
End Sub
As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.
The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.
Copy Ranges by Rows
Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.
The Code
Option Explicit
Sub copyByRows()
Const dstName As String = "ALL SURVEY"
Const dstFirst As String = "E2"
Const srcRange As String = "U3:X3"
Const Delimiter As String = ","
Dim ExceptionsList As String
ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
arl.Add ws.Range(srcRange).Value
End If
Next ws
Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
Dim Item As Variant
Dim i As Long
Dim j As Long
Dim k As Long
For Each Item In arl
For i = 1 To srCount
k = k + 1
For j = 1 To cCount
Data(k, j) = Item(i, j)
Next j
Next i
Next Item
dst.Range(dstFirst).Resize(k, cCount).Value = Data
End Sub
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
I've got three sheets - main,specimen and output in an excel workbook. The sheet main and speciment contain some information. Some of the information in two sheets are identical but few of them are not. My intention is to paste those information in output which are available in speciment but not in main.
I've tried like [currently it fills in lots of cells producing duplicates]:
Sub getData()
Dim cel As Range, celOne As Range, celTwo As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")
For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
Next celOne
Next cel
End Sub
main contains:
UNIQUE ID FIRST NAME LAST NAME
A0000477 RICHARD NOEL AARONS
A0001032 DON WILLIAM ABBOTT
A0290191 REINHARDT WESTER CARLSON
A0290284 RICHARD WARREN CARLSON
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
A0003916 GEORGES YOUSSEF ACCAOUI
specimen contains:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290284 RICHARD WARREN CARLSON
A0290688 THOMAS A CARLSTROM
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
output should contain [EXPECTED]:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290688 THOMAS A CARLSTROM
How can I achieve that?
If you have the latest version of Excel, with the FILTER function and dynamic arrays, you can do this with an Excel formula.
I changed your Main and Specimen data into tables.
On the Output worksheet you can then enter this formula into a single cell:
=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))
The remaining fields will autopopulate with the results.
For a VBA solution, I like to use Dictionaries, and VBA arrays for speed.
'set reference to microsoft scripting runtime
' or use late-binding
Option Explicit
Sub findMissing()
Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
Dim dN As Dictionary, dM As Dictionary
Dim vMain As Variant, vSpec As Variant, vOut As Variant
Dim I As Long, v As Variant
With ThisWorkbook
Set wsMain = .Worksheets("Main")
Set wsSpec = .Worksheets("Specimen")
Set wsOut = .Worksheets("Output")
End With
'Read data into vba arrays for processing speed
With wsMain
vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
With wsSpec
vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
dN.Add Key:=vMain(I, 1), Item:=I
Next I
'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
If Not dN.Exists(vSpec(I, 1)) Then
dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
End If
Next I
'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
vOut(0, 1) = "UNIQUE ID"
vOut(0, 2) = "FIRST NAME"
vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
I = I + 1
vOut(I, 1) = dM(v)(1)
vOut(I, 2) = dM(v)(2)
vOut(I, 3) = dM(v)(3)
Next v
Dim R As Range
With wsOut
Set R = .Cells(1, 1)
Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))
With R
.EntireColumn.Clear
.Value = vOut
.Style = "Output"
.EntireColumn.AutoFit
End With
End With
End Sub
Both show the same result (except the formula solution does not bring over the column headers; but you can do that with a formula =mnTbl[#Headers] in the cell above the original formula above).
Another option is to join the values of each row in each range and store them in arrays.
Then compare arrays and output the unique values.
In this case, your uniques come from evaluating the whole row, and not just the Unique ID.
Please read code's comments and adjust it to fit your needs.
Public Sub OutputUniqueValues()
Dim mainSheet As Worksheet
Dim specimenSheet As Worksheet
Dim outputSheet As Worksheet
Dim mainRange As Range
Dim specimenRange As Range
Dim mainArray As Variant
Dim specimenArray As Variant
Dim mainFirstRow As Long
Dim specimenFirstRow As Long
Dim outputCounter As Long
Set mainSheet = ThisWorkbook.Worksheets("main")
Set specimenSheet = ThisWorkbook.Worksheets("specimen")
Set outputSheet = ThisWorkbook.Worksheets("output")
' Row at which the output range will be printed (not including headers)
outputCounter = 2
' Process main data ------------------------------------
' Row at which the range to be evaluated begins
mainFirstRow = 2
' Turn range rows into array items
mainArray = ProcessRangeData(mainSheet, mainFirstRow)
' Process specimen data ------------------------------------
' Row at which the range to be evaluated begins
specimenFirstRow = 2
' Turn range rows into array items
specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)
' Look for unique values and output results in sheet
OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray
End Sub
Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant
Dim dataRange As Range
Dim evalRowRange As Range
Dim lastRow As Long
Dim counter As Long
Dim dataArray As Variant
' Get last row in sheet (column 1 = column A)
lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
' Set the range of specimen sheet
Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)
' Redimension the array to the number of rows in range
ReDim dataArray(dataRange.Rows.Count)
counter = 0
' Join each row values so it's easier to compare them later and add them to an array
For Each evalRowRange In dataRange.Rows
' Use Trim function if you want to omit the first and last characters if they are spaces
dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)
counter = counter + 1
Next evalRowRange
ProcessRangeData = dataArray
End Function
Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)
Dim specimenFound As Boolean
Dim specimenCounter As Long
Dim mainCounter As Long
' Look for unique values ------------------------------------
For specimenCounter = 0 To UBound(specimenArray)
specimenFound = False
' Check if value in specimen array exists in main array
For mainCounter = 0 To UBound(mainArray)
If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True
Next mainCounter
If specimenFound = False Then
' Write values to output sheet
outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
outputCounter = outputCounter + 1
End If
Next specimenCounter
End Sub
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