use range object as part of a loop - excel

I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub

Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next

Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value

Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.

The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.

Related

VBA - Remove cell that contains word from same column

I've seen similar posts out there but not quite the same and seem to be confused on the results I'm getting...
I essentially need to de-dupe a column on LIKE words, so it's somewhat straightforward but apparently not as easy as I thought.
I have a dataset like soo...
When I run my macro it removes rows (as I intended), but doesn't seem to remove all the rows or the wrong rows...
It actually removes the highlighted/yellow rows
I was thinking it should actually remove something like the bottom rows.. where it would keep "aerospace" but remove "aerospace 2019", since the 2019 is kinda redundant and not applicable to me.
My macro is simple, but I thought it would do the trick... what am I doing wrong?
Sub container()
Dim ws As Worksheet, rw As Long, col As Long, i As Long
Set ws = ActiveSheet 'or whatever
i = 2
'For col = 2 To 5 'placeholder in case multiple columns are needed - remove Set col above
For rw = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row 'from row 1 til last non-empty row
v = ws.Cells(rw, 2).Value 'set range
If Cells(i, 2).Value Like v Then 'determine if the cell contains the value of the word
Cells(i, 2).EntireRow.Delete 'delete
i = i + 1
End If
Next rw
'Next col
End Sub
After Ron's post I was able to create the below, but appears I'm still stuck. I think I've just been looking at this too long.
Sub container()
Dim ws As Worksheet, rng As Range, i As Long, rw As Long
Set ws = ActiveSheet 'or whatever
Set rng = ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) 'set array range
i = Range("B" & Rows.Count).End(xlUp).Row
For rw = ws.Cells(Rows.Count, 1).End(xlDown).Row To 2
v = ws.Cells(rw, 2).Value
If InStr(1, v, rng) > 0 Then
cell.EntireRow.Delete
i = i - 1
End If
Next rw
End Sub

How to fix 'Run-time error '1004' PasteSpecial

I have a file (called original) that has partially information for each row. Each row has a file name column (from where information is to be captured from).
For each row I'd like to open up the file in the file name column, and grab information from certain rows.
In the file it is only one column, with rows "Supplier Number : _____", the location of this row is variable, so I'd like to iterate through each row in the file to copy this cell value and paste it into the original file in the corresponding row.
This is what I have so far:
Const FOLDER_PATH = "C:\Users\[user]\Downloads\"
Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim source As String
Dim target As String
Dim update As String
Dim rowT As Integer
rowT = 2
rowTT = 1
Dim rowRange As Range
Dim colRange As Range
Dim rowRangeT As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowT As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A2:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
source = FOLDER_PATH & wks.Cells(i, 18).Value 'the name of the file we want to grab info from in this Column, always populated
'if the cell is empty, search through the file for "Supplier Number : "
If IsEmpty(wks.Cells(rowT, 19)) Then
Set wb = Workbooks.Open(source)
wb.Activate
LastRowT = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = wks.Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
Range("A" & rowTT).Select
Selection.Copy
Windows("Get Supplier Number.xlsm").Activate
Range("A" & rowT).Select
wks.Paste
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
Next rrow
ScreenUpdating = True
End Sub
I get the pastespecial error 1004.
What is expected is that for each row in "Get Supplier Number.xlsm", the row's A column is updated with the information
Thank you for helping!
First of all you should get rid of Activate and Select methods. You don't have to use them and they give nothing to your code. Using them is not a good approach.
To avoid them you should use specific references. Which you are doing so, until a specific point. Inside the for loop, after setting the wb, replace everything with the following:
With wb.Worksheets(1)
LastRowT = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = .Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
.Range("A" & rowTT).Copy wks.Range("A" & rowT)
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
End With
I think this should do the job for you.
PS: If you need just the value of the cell in the opened workbook, then you could replace the Copy line with a simple equality:
wks.Range("A" & rowT) = .Range("A" & rowTT)

How can I compare cells in different rows and insert-right if lower cell if not the same?

How can I compare cells in two rows and and match the lower cell value to the upper cell value, if the two are different? Here is some the same data I am working with and what I hope to see after the code runs.
Before:
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [ID_1], [ID_2], [GAS_ADJ], [OBJ_ADJ]
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [GAS_ADJ], [OBJ_ADJ]
After:
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [ID_1], [ID_2], [GAS_ADJ], [OBJ_ADJ]
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], NULL AS [ID_1], NULL AS [ID_2], [GAS_ADJ], [OBJ_ADJ]
I think the code will basically look like this, but I haven't gotten the insert-right working properly.
Sub CompareCellsDiffRows()
Dim bothrows As Range, i As Integer
Set bothrows = Selection
With bothrows
For i = 1 To .Columns.Count
If Not StrComp(.Cells(1, i), .Cells(2, i), vbBinaryCompare) = 0 Then
' magic happens here
End If
Next i
End With
End Sub
As you may have guessed, I'm dealing with hundreds of fields in several tables and trying to Union everything together, so all these field names have to match up in the correct order.
Thanks.
I am assuming, as per your example, that the first row is the one that will be always complete.
Sub CompareRowDifferences()
Dim sht As Worksheet
Dim i, LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.Cells.SpecialCells(xlLastCell).Column
With sht
For i = 1 To LastColumn
If StrComp(.Cells(1, i), .Cells(2, i), vbBinaryCompare) <> 0 Then
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = "NULL AS " & .Cells(1, i).Value2
End If
Next i
End With
End Sub
Hope it helps
Regarding your second question (if they are not ordered) and assuming always that the first line is the ones that rules...
Sub CompareRowDifferences()
Dim sht As Worksheet
Dim i, j, LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.Cells.SpecialCells(xlLastCell).Column
j = 0
With sht
For i = 1 To LastColumn
Test = Application.WorksheetFunction.CountIf(Range _
(Cells(2, i), Cells(2, LastColumn + j)), .Cells(1, i).Value2)
If Test >= 1 Then
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = .Cells(1, i).Value2
Else
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = "NULL AS " & .Cells(1, i).Value2
End If
j = j + 1
Next i
Range(Cells(2, LastColumn), Cells(2, LastColumn + j)).ClearContents
End With
End Sub
This procedure identifies and uses the row with a higher number of fields (i.e. no-empty cells), and uses it as "model" to update the other row regardless of the position of the fields in the other row.
Sub Headers_Comparison(rInput As Range)
Dim aOut As Variant, aSrc As Variant, aTrg As Variant
Dim bMatch As Byte, bRow As Byte, b As Byte
With WorksheetFunction
Rem Validate Fields in Rows
If .CountA(rInput.Rows(1)) > .CountA(rInput.Rows(2)) Then
bRow = 2
aSrc = .Transpose(.Transpose(rInput.Rows(1).Value2))
aTrg = .Transpose(.Transpose(rInput.Rows(2).Value2))
Else
bRow = 1
aSrc = .Transpose(.Transpose(rInput.Rows(2).Value2))
aTrg = .Transpose(.Transpose(rInput.Rows(1).Value2))
End If
aOut = aTrg
For b = 1 To UBound(aSrc)
bMatch = 0
On Error Resume Next
bMatch = .Match(aSrc(b), aTrg, 0)
On Error GoTo 0
aOut(b) = IIf(bMatch > 0, vbNullString, "NULL AS ") & aSrc(b)
Next: End With
rInput.Rows(bRow).Value = aOut
End Sub
It should be called in this manner:
Call Headers_Comparison(rSel) 'update with required range
I think I just figured it out!
Sub CompareRowDifferences()
Dim i As Integer
Dim sht As Worksheet
Dim LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.UsedRange.Columns(sht.UsedRange.Columns.Count).Column
For i = 1 To LastColumn
If Not StrComp(sht.Cells(1, i), sht.Cells(2, i), vbBinaryCompare) = 0 Then
' magic happens here
Set Rng = sht.Cells(2, i)
Rng.Insert Shift:=xlToRight
sht.Cells(2, i).Value = "NULL AS " & sht.Cells(1, i).Value
End If
Next i
End Sub
This seems to work. Although, this is a pretty simple solution. I understand it would be much more complex if the order of names the lower row changed. This works ONLY because the names in row 2 match the names in row 1, there are just fewer names. I would love to see what the code would look like if the order of the row 2 names was switch around, compared to the row 1 names.

Deleting Duplicates while ignoring blank cells in VBA

I have some code in VBA that is attempting to delete duplicate transaction IDs. However, i'd like to ammend the code to only delete duplicates that have a transaction ID - so, if there is no transaction ID, i'd like that row to be left alone. Here is my code below:
With MySheet
newLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
newLastCol = .Cells(5 & .Columns.Count).End(xlToLeft).Column
Set Newrange = .Range(.Cells(5, 1), .Cells(newLastRow, newLastCol))
Newrange.RemoveDuplicates Columns:=32, Header:= _
xlYes
End With
I was also wondering - in the remove.duplicates command - is there a way where I can have the column I want looked at to be named rather than have it be 32 in case I add or remove columns at a later date?
Here is an image of the data: I'd like the ExchTransID column that have those 3 blank spaces to be left alone.
Modify and try the below:
Option Explicit
Sub test()
Dim Lastrow As Long, Times As Long, i As Long
Dim rng As Range
Dim str As String
'Indicate the sheet your want to work with
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row with IDs
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the range with all IDS
Set rng = .Range("A1:A" & Lastrow)
'Loop column from buttom to top
For i = Lastrow To 1 Step -1
str = .Range("A" & i).Value
If str <> "" Then
Times = Application.WorksheetFunction.CountIf(rng, str)
If Times > 1 Then
.Rows(i).EntireRow.Delete
End If
End If
Next i
End With
End Sub

Transferring Cell Values Between Worksheets | Str Looper

Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Resources