I have an Excel Form that I use, It holds 3 Worksheets - Form, Data and Entries. Basically When you call a new Form with the Button it looks for the lastrow in the Entries sheet (Range "A") adds 1 and that's your new Form ID. Having multiple users use this form I have it set that It also adds the number in the Entries sheet before the form is filled, in order to reserve it so a next user cannot get duplicates.
Here's where I get caught up. I'd like to have currentrow find that sheet id and paste the data in that row, but the code I have is just adding a new row.
This is what it looks like.
Sub Submit()
Dim rng1 As Range
Dim rng2 As Range
Dim multiplerange As Range
Dim currentrow As Long
Dim sheetid As String
Set rng1 = Range("M1,M2,B2,F6,B7,B8,B9,B11,D11,B13,D13,I6,M6,I7,I8,I9,I11,K11,I13,K13,B15,B18,B22,E22,B23,B24,B26,E26,I22,J22,M22,K24,M24,I24,I26,K26,M26,B29,E29,B30,B31,B33,E33,I29,J29,M29,K31,M31,I31,I33,K33,M33,B36,E36,B37,B38,B40,E40,I36,J36,M36,K38,M38,I38,I40,K40,M40")
Set rng2 = Range("G2")
Set multiplerange = Union(rng1, rng2)
Dim WSEntries As Worksheet
Dim WSForm As Worksheet
Set WSEntries = Sheets("Entries")
Set WSForm = Sheets("Form")
sheetid = WSForm.Range("M1").Text
Dim lastrow As Integer
lastrow = WSEntries.Cells(Rows.Count, "A").End(xlUp).Row
For currentrow = 3 To lastrow
If Cells(currentrow, 1) = sheetid Then
Dim i As Integer
i = 1
For Each c In multiplerange
WSEntries.Cells(currentrow + 1, i) = c
i = i + 1
Next
Else
i = 1
For Each c In multiplerange
WSEntries.Cells(lastrow + 1, i) = c
i = i + 1
Next
End If
Next
End Sub
Any help would be great. Thanks
Edit: I also didn't add all my declared items but this is the other part of the script. I've got everything else working just the paste part that I'm having issue with
Got it working!! switched to a Range method
lastrow = WSEntries.Cells(Rows.Count, "A").End(xlUp).Row
For currentrow = 3 To lastrow
If WSEntries.Range("A" & currentrow) = sheetid Then
Dim i As Integer
i = 1
For Each c In multiplerange
WSEntries.Cells(currentrow, i) = c
i = i + 1
Related
I have a value in column A on the transactions sheet which contains an Identifier for a Deal.
To be able to find out the customer information for this Deal I look in another sheet called Deal Information. Here there is a value in Column F which matches a value in Column A on the transactions sheet. Although on the Deal Information sheet it lists all the customers who are part of this deal as well as a unique identifier for each of the customers.
On the transactions sheet I have created a new column where by I want to display the list of ID's associated to a particular deal in comma delimited format if possible if not then a space will be good too.
transactions data:
Column A:ID Column: AA: BID Multiple
1 ?
2 ?
3 ?
4 ?
Roots data:
Column C: ID Column: D: BID
1 100
1 200
1 300
2 101
Expected Result in transaction table based on example.
Column A ID Column AA: BID Multiple
1 100,200,300
2 101
3 ?
4 ?
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("Roots")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim valuesArr()
valuesArr = ws.Range("F2:G" & lastRow) ' 1 TO 4, 1 TO 2
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim valuesString As String
Dim currValue As Long
Dim currRotation As Long
Dim index As String
For currRotation = LBound(valuesArr, 1) To UBound(valuesArr, 1)
index = valuesArr(currRotation, 1)
currValue = CStr(valuesArr(currRotation, 2))
If Not dict.Exists(index) Then
dict.Add index, currValue
Else
dict(index) = dict(index) & ";" & currValue
End If
Next currRotation
Dim wsTarget As Worksheet
Dim lastRowTarget As Long
Set wsTarget = ThisWorkbook.Worksheets("transactions")
lastRow = wsTarget.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim valuesArr2()
valuesArr2 = wsTarget.Range("A2:AA" & lastRow)
Dim testValue As String
For currRotation = LBound(valuesArr2, 1) To UBound(valuesArr2, 1)
testValue = dict(CStr(valuesArr2(currRotation, 1)))
If testValue = vbNullString Then testValue = "?"
valuesArr2(currRotation, 27) = testValue
Next currRotation
wsTarget.Range("A2").Resize(UBound(valuesArr2, 1), UBound(valuesArr2,
27)) = valuesArr2
End Sub
This does an unordered, for the original posting . Assumes data starts in row 2 and has layout as shown below.
Column D being where the concatenated string is output.
*Please note repeated edits to the original question may mean code will no longer fit the stated requirements.
Option Explicit
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("Roots")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim valuesArr()
valuesArr = ws.Range("A2:B" & lastRow) ' 1 TO 4, 1 TO 2
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim currValue As Long
Dim currRotation As Long
Dim index As String
For currRotation = LBound(valuesArr, 1) To UBound(valuesArr, 1)
index = valuesArr(currRotation, 1)
currValue = CStr(valuesArr(currRotation, 2))
If Not dict.exists(index) Then
dict.Add index, currValue
Else
dict(index) = dict(index) & ";" & currValue
End If
Next currRotation
Dim wsTarget As Worksheet
Dim lastRowTarget As Long
Set wsTarget = ThisWorkbook.Worksheets("transactions")
lastRow = wsTarget.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim valuesArr2()
valuesArr2 = wsTarget.Range("A2:D" & lastRow)
Dim testValue As String
For currRotation = LBound(valuesArr2, 1) To UBound(valuesArr2, 1)
testValue = dict(CStr(valuesArr2(currRotation, 1)))
If testValue = vbNullString Then testValue = "?"
valuesArr2(currRotation, 4) = testValue
Next currRotation
wsTarget.Range("A2").Resize(UBound(valuesArr2, 1), UBound(valuesArr2, 2)) = valuesArr2
End Sub
Edited as per OP's amended input and output columns
as per your examples, IDs are consecutive in Roots sheet
so you may go as follows
Sub main()
Dim cell As Range
With Worksheets("transactions") 'reference "transaction" sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) 'loop through referenced sheet column A cells from row 2 down to last not empty one
cell.Offset(, 26).value = GetIDDeals(cell.value) 'write in current cell offset 26 columns (i.e. column AA) the value of the BID
Next
End With
End Sub
Function GetIDDeals(ID As Variant) As String
With Worksheets("Roots")
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference its column C cells from row 1 (header) down to last not empty one
.AutoFilter Field:=1, Criteria1:=ID ' filter referenced cells on 1st column with passed ID content
Select Case Application.WorksheetFunction.Subtotal(103, .Columns(1)) 'let's see how many filtered cells
Case Is > 2 'if more than 2, then we have more than 1 filtered value, since header gets always filtered
GetIDDeals = Join(Application.Transpose(.Offset(1, 1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value), ",")
Case 2 'if two filtered cells, then we have 1 filtered value, since header gets always filtered
GetIDDeals = .Offset(1, 1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value
End Select
End With
.AutoFilterMode = False
End With
End Function
I found this piece of code which does 99% what i need.
Procedure description: In my workbook there is one SQL Sheet with named columns, based on the Column Header I have to loop through all other sheets (variable from 10 to 50 sheets) in the workbook where the Column Header has the identical name, all columns from the source SQL Sheet are copied to the goal sheets. In the goal sheets the column header consist of 4 rows, in the source the column header has only 1 row.
Problem-1: How can I copy the column without the header and paste the content with an offset of 4 rows.
Problem-2: How can I copy only the real used range, the workbook is getting huge.
Code-Sample:
Sub Test()
Dim Sh2Cell As Range
Dim Sh3Cell As Range
Dim ShQuelleTitle As Range
Dim ShZielTitle As Range
'Here we loop through the Range where the Title Columns for source and goal sheet are stored
'The columns in the Source Sheet do not have the same order as in the Goal Sheet
Set ShQuelleTitle = Sheets("SQL").Range("SQL_Titel")
Set ShZielTitle = Sheets("Ziel").Range("Ziel_Titel")
For Each Sh2Cell In ShQuelleTitle
For Each Sh3Cell In ShZielTitle
If Sh2Cell = Sh3Cell Then
Sh2Cell.EntireColumn.Copy Sh3Cell.EntireColumn
' Problem-1 is: in the goal sheet the copy range has to be shifted 4 rows down because
' i have different column title structure which has to be maintained (with this goal
' sheet there happens a txt-export from another external developer.
' Problem-2 is: how can i only copy and paste cells with content - the worksheets are getting
' huge on file size if the copy range has some weird formatting
End If
Next
Next
End Sub
Sub UpDateData()
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim wData As Worksheet
Dim Process(1 To 2) As String
Dim iProc As Long
Dim Dict As Object
Process(1) = "SQL"
Process(2) = "ACCOUNT ACC STD"
Set wData = Sheets("ACCOUNT")
Set Dict = CreateObject("Scripting.Dictionary")
With wData
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Len(.Cells(1, j)) > 0 Then Dict.Add LCase$(.Cells(1, j)), j
Next j
End With
i = 5
For iProc = 1 To 2
With Sheets(Process(iProc))
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Dict.exists(LCase$(.Cells(1, j))) Then
k = Dict(LCase$(.Cells(1, j)))
.Cells(2, j).Resize(n - 1).Copy wData.Cells(i, k).Resize(n - 1)
End If
Next j
End With
i = i + n - 1
Next iProc
End Sub
You can loop through range as if it was an array:
Dim srcRng As Range
dim trgRng As Range
Dim iii As Long
Dim jjj As Long
Dim iRowStart As Long
Set srcRng = Sheets("your_source_sheet").Range("source_range")
Set trgRng = Sheets("your_target_sheet").Range("target_range")
iRowStart = 4
For iii = iRowStart To UBound(srcRng(), 1)
For jjj = 1 To UBound(srcRng(), 2) ' <~~ necessary only if you were dealing with more than one column
With trgRng
If srcRng(iii, jjj).Value <> "" Then .Cells(.Rows.Count + 1, jjj).Value = srcRng(iii, jjj).Value
End With
Next jjj
Next iii
Set srcRng = Nothing
Set trgRng = Nothing
I haven't tested the code, but it should do the trick
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(4, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
I'd like the code to paste 'cashb' underneath 'rngcel', but every time
I run the code 'cashb''s value appears above 'rngCel'.value. Rngcell's range is from A2:A34, I'd like 'Cashb' to appear right below it at A35. I tried putting 'A35' in the
range but it does not work.
This is the code that I want to appear below rngcel.value.
Sheets(" Price").Range("A35").Resize(Cashb.Rows.Count).Value = Cashb.Value
I'd also like to return the column that's 5 columns to the right of "cashb"range
I appreciate any help that I receive.
This is the code that I have.Thanks in advance.
Sub liveP()
Application.ScreenUpdating = False
Dim rngTicker As Range
Dim rngCel As Range
Dim Cashb As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Live"
Set rngTicker = Worksheets("prices").Range("H16:H200")
Set Cashb = Sheets("prices").Range("cashbalances")
For Each rngCel In rngTicker
If rngCel.Font.ColorIndex = 33 Then
Worksheets("Live").Cells(Rows.Count, 1).End(xlUp).offset(1).Resize(1, 2).Value = Array(rngCel.offset(, "-7").Value, rngCel.Value) ' this is range cell value'
WorkSheets("Live").Range("A35").Resize(Cashb.Rows.Count).Value = Cashb.Value.offset ' this is the value I'd like to appear under rngcel value
'New data that im posting on the Live sheet'
Sheets("Live").Range("C2:H33").Formula = "=($B2 +$C5)"
Sheets("Live").Range("A1") = "Header1"
Sheets("Live").Range("B1") = "Header2"
Sheets("Live").Range("C1") = "Header3"
Sheets("Live").Range("D1") = "Header4"
Sheets("Live").Range("E1") = "Header5"
Sheets("Live").Range("F1") = "Header6"
End If
Next
Application.ScreenUpdating = True
End Sub
Try This
Sub liveP()
Application.ScreenUpdating = False
Dim rngTicker As Range
Dim rngCel As Variant 'used in for each this should be variant
Dim Cashb As Range
Dim ws As Worksheet
Dim LastRow As Long 'dimensioned variable for the last row
Dim CashbRows As Long 'dimensioned variable for Cashb rows
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Live"
Set rngTicker = Worksheets("prices").Range("H16:H200")
Set Cashb = Sheets("prices").Range("cashbalances")
'Assuming "cashbalances" is a named range in the worksheet
CashbRows = Cashb.Rows.Count
For Each rngCel In rngTicker
If rngCel.Font.ColorIndex = 33 Then
With Worksheets("Live")
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'set lastrow variable
.Cells(LastRow, 1) = rngCel.Offset(0, -7).Value 'putting value 7 columns before into live worksheet column A
.Cells(LastRow, 2) = rngCel.Value 'putting value into live worksheet column B
.Range(.Cells(35, 1), .Cells(35 + CashbRows, 1)) = Cashb.Offset(, 5).Value 'im not really sure if this line is going to work at all
'New data that im posting on the Live sheet'
.Range("C2:H33").Formula = "=($B2 +$C5)"
.Range("A1") = "Header1"
.Range("B1") = "Header2"
.Range("C1") = "Header3"
.Range("D1") = "Header4"
.Range("E1") = "Header5"
.Range("F1") = "Header6"
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Modifications:
rngCel is now a variant not a range
Using a LastRow Variable to get away from offset
Removed the array when placing data into "LIVE" because why not
CashbRows will now only be calculated one time before the loop. Saving time
The With Worksheets("Live") statement is a time saving measure.
You were calling A35 as a range, which it is not, then resizing to a range maybe? Hard to know when I cant tell what "cashbalances" is. If "cashbalances is only 1 row or may ever be 1 row, then you will need to add an If Then Else control to handle it.
Also A35 gets overwritten every single loop... so not sure what you want to do there.
I hope I was able to understand your questions well enough to get you going in the right direction.
EDIT
Stop treating "cashbalances" as a named range. I believe VBA is hanging onto the original row numbers of the range, similar to how Variant arrays start at 1 when assigned as I do in the following. It does not look like you are modifying "cashbalances" so create a variant array before the loop but after CashbRows.
EXAMPLE:
Dim CB() as variant, j as long
with sheets("PUT THE SHEET NAME OR INDEX HERE")
CB = .range(.cells(1,6), .cells(CashbRows,6)).value 'address to whatever .offset(,5) is
'i assumed cashb was in column A
Instead of .Range(.Cells(35, 1), .Cells(35 + CashbRows, 1)) = Cashb.Offset(, 5).Value Use:
For j = 1 to CashbRows
.cells(34 + j, 1) = CB(j)
Next j
I am currently working on a macro and I had it working 100% like I wanted, but when I went to move the control group to a different sheet, I've started getting all sorts of problems. Here is the code:
Sub Duplicate_Count()
'Diclare Variables
Dim LastRow As Long
Dim value1 As String
Dim value2 As String
Dim counter As Long
Dim startRange As Long
Dim endRange As Long
Dim inColumn As String
Dim outColumn As String
Dim color As Long
counter = 0
Dim sht As Worksheet
Dim controlSht As Worksheet
Set sht = Worksheets("Sheet1")
Set controlSht = Worksheets("Duplicate Check")
'Find the last used row in column L
LastRow = sht.Cells(Rows.Count, "L").End(xlUp).Row
'set default ranges
startRange = 2
endRange = LastRow - 1
inColumn = "L"
outColumn = "N"
'check for user inputs
If controlSht.Cells(8, "B") <> "" Then
startRange = controlSht.Cells(8, "B")
End If
If controlSht.Cells(8, "C") <> "" Then
endRange = controlSht.Cells(8, "C")
End If
If controlSht.Cells(11, "C") <> "" Then
Column = controlSht.Cells(11, "C")
End If
If controlSht.Cells(14, "C") <> "" Then
Column = controlSht.Cells(14, "C")
End If
color = controlSht.Cells(17, "C").Interior.color
'Search down row for duplicates
Dim i As Long
For i = startRange To endRange
'Sets value1 and value2 to be compared
value1 = sht.Cells(i, inColumn).Value
value2 = sht.Cells(i + 1, inColumn).Value
'If values are not diferent then counter will not increment
counter = 1
Do While value1 = value2
sht.Cells(i, inColumn).Interior.color = color
sht.Cells(i + counter, inColumn).Interior.color = color
counter = counter + 1
value2 = sht.Cells(i + counter, inColumn).Value
Loop
'Ouput the number of duplicates on last duplicates row
If counter <> 1 Then
sht.Cells(i + counter - 1, outColumn) = counter
i = i + counter - 1
End If
Next i
End Sub
This is my first program so I apologize for all the mistakes. This code does exactly what I want except for finding the last row if there is no user input. It always says the last row is 1, when it should be 110460. I'm not sure if it's grabbing from the wrong sheet or if there is an error in my logic.
This should be easy to fix by just Activating the sheet first. I can't recall the exact syntax but since you tagged this macros just record a macro, then select a sheet and click on it somewhere. Then open up the macro it will say something like Sheets("sheet name".Activate. Or Sheets("sheet name").Select. Repeat that for each worksheet you want to run the macro on. To clarify, each time your macro finds the last row on 1 sheet, then you Activate or Select the next worksheet and find the last row again. Suppose this is being called in a loop through list of worksheet names.
I changed the "L" to an 11, and it all seems to work now. Why it wants it this way i have no clue, but it works.
I always do it like this.
Sub FindingLastRow()
'PURPOSE: Different ways to find the last row number of a range
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Using UsedRange
sht.UsedRange 'Refresh UsedRange
LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
'Using Table Range
LastRow = sht.ListObjects("Table1").Range.Rows.Count
'Using Named Range
LastRow = sht.Range("MyNamedRange").Rows.Count
'Ctrl + Shift + Down (Range should be first cell in data set)
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
End Sub
https://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba
I am creating a VBA application that will find the text that I have entered in a certain range (Should be dynamic, in order for me to input more in the future). With that the entered texts in the range will look for the words in another sheet column:
Example:
And it will look for the words inputted in another sheet.
Dim Main as Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 as Worksheet
Set Raw2 = Sheets("Sheet2")
LookFor = Main.Range(D8:100)
Fruits = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).row
For e = lastRow To 2 Step -1
value = Raw2.Cells(e, 7).value
If Instr(value, LookFor) = 0 _
Then
Raw2.Rows(e).Delete
Honestly I am not sure how to proceed. And the mentioned code is just experiment. Desired output is to delete anything in sheet2 except for the rows that contain the words that I have inputted in the "Look for the words". Hope you can help me. Thank you.
This should do the trick :
Sub Sevpoint()
Dim Main As Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 As Worksheet
Set Raw2 = Sheets("Sheet2")
Dim LooKFoR() As Variant
Dim LastRow As Double
Dim i As Double
Dim j As Double
Dim ValRow As String
Dim DelRow As Boolean
LooKFoR = Main.Range(Main.Range("G8"), Main.Range("G" & Main.Rows.Count).End(xlUp)).Value
LastRow = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
ValRow = Raw2.Cells(i, 7).Value
DelRow = True
'MsgBox UBound(LooKFoR, 1)
For j = LBound(LooKFoR, 1) To UBound(LooKFoR, 1)
If LCase(ValRow)<>LCase(LooKFoR(j, 1)) Then
Else
DelRow = False
Exit For
End If
Next j
If DelRow Then Raw2.Rows(i).Delete
Next i
End Sub