This Macro adds data in Cell A10. Now the data gets overwritten every time i run it again. How can i add 1 cel below?
Sub Invoer()
Dim Debiteurnummer As Integer
Dim Aantalpallets As Integer
Dim Totaalgewicht As Integer
Debiteurnummer = InputBox("Debiteurnummer invoeren")
Aantalpallets = InputBox("Aantal Pallets?")
Totaalgewicht = InputBox("Totaal Gewicht?")
Range("A10").Value = Debiteurnummer
Range("A10").Offset(0, 2) = Aantalpallets
Range("A10").Offset(0, 3) = Totaalgewicht
End Sub
Add a dynamic search for LastRow:
Sub Invoer()
Dim Debiteurnummer As Integer
Dim Aantalpallets As Integer
Dim Totaalgewicht As Integer
Dim LastRow As Long
Debiteurnummer = InputBox("Debiteurnummer invoeren")
Aantalpallets = InputBox("Aantal Pallets?")
Totaalgewicht = InputBox("Totaal Gewicht?")
LastRow = Cells(Rows.count, "A").End(xlUp).row
Range("A" & LastRow + 1).Value = Debiteurnummer
Range("A" & LastRow + 1).Offset(0, 2) = Aantalpallets
Range("A" & LastRow + 1).Offset(0, 3) = Totaalgewicht
End Sub
Related
I am learning VBA,
I have data in sheet1 18 rows with 5 columns and Sheet2 3 rows with 8 columns
I would like to loop data and print in NOTEPAD like,
Rows 1 - 6 from sheet1 then Row 1 from sheet2
Rows 7 - 12 from sheet1 then Row 2 from sheet2
Row 13 - 18 from sheet1 then Row 3 from Sheet2, so on.
Here is my code,
Sub Looping()
Dim str As String
Dim MaxStrLen As String
Dim rest As Integer
Dim Lstr As Integer
Dim LMstr As Integer
Dim MStr As Integer
Dim LR As Range
Dim CNT As Integer
Dim LastRow As Long
Dim LastCol As Long
Dim LRow As Long
Dim LCol As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim i As Long
Dim j As Long
Dim Page_Break As Long
Dim k As Long
Dim PB As Long
Dim x As Long
Dim y As Long
Dim rng As Range
Set rng = Range("A1:E6")
Dim FilePath As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")
Open "C:\Users\Antony\Music\Excel Macros\Test.txt" For Output As #2
'''''FIRST FIVE LINES WILL PRINT IN THE NOTEPAD
With ws1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRow = ws2.Cells(.Rows.Count, 1).End(xlUp).Row
LCol = ws2.Cells(1, .Columns.Count).End(xlToLeft).Column
BlkSize = 6 'data consists of blocks of 6 rows
For i = 1 To LastRow
sOut = vbNullString
LengthRow = i
Do While LengthRow > BlkSize
LengthRow = LengthRow - BlkSize
Loop
'LengthRow points to row where char length is to be taken from
For j = 1 To LastCol
str = .Cells(i, j).Value
If str <> Empty Then
MStr = ws2.Cells(LengthRow, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
Else
MStr = ws2.Cells(LengthRow, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
End If
Next
Print #2, sOut
Next
End With
'''''LAST LINE WILL PRINT IN THE SAME NOTEPAD
With ws3
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
slast = vbNullString
For k = 2 To LRow
str = Join(Application.Transpose(Application.Transpose(.Cells(k, "A").Resize(1, LastCol).Value)), "##")
str = Replace(str, "=", vbNullString)
Print #2, str
Next
Endtext = "EODR"
Print #2, slast & Endtext
End With
'Loop
Close #2
End Sub
You can embed the loops:
For i = 0 to 2
For j = 1 to 6
Write Sheet1 row = i * 6 + j to file 'this line not actual code
Next j
Write Sheet2 row = i + 1 to file 'this line not actual code
Next i
I need help to copy and paste a single row for every cell in another column multiple times starting in the second row.
The raw data looks like this
I need it to look like this
ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:="=Sheet2!R2C5:R2C7"
ActiveWorkbook.Names("data1").Comment = "" Range("data1").Copy
Range("B1").Select ActiveCell.Offset(1, 0).Select ActiveCell.PasteSpecial
Here is where I get lost. I am not sure how to loop it down and then keep it going and copy column a down and then the defined range again.
I also tried this:
Dim LastRow As Variant
Dim LastRowA As Variant
Dim Row As Range
Dim i As Integer
With Sheets("Store_Item_copy")
LastRow = .Range("A2" & Row.Count).End(xlUp).Row
End With
Range("A2" & LastRow).Copy
For i = 2 To LastRow
i = i + 1
With Sheets("Store_Item_copy")
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
End With
LastRowA.Offset(1, 0).Select
ActiveCell.PasteSpecial
Next i
Here is one way to do it using arrays.
Option Explicit
Public Sub PopulateColumns()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet1") 'Change as appropriate
Dim yearArr()
yearArr = wsSource.Range("E2:F" & wsSource.Cells(wsSource.Rows.Count, "E").End(xlUp).Row).Value
Dim storesArr()
storesArr = wsSource.Range("A2:C" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Value
Dim resultArr()
ReDim resultArr(1 To UBound(storesArr, 1) * UBound(yearArr, 1), 1 To 3)
Dim counter As Long
Dim counter2 As Long
Dim x As Long, y As Long
For x = 1 To UBound(yearArr, 1)
counter2 = counter2 + 1
For y = 1 To UBound(storesArr, 1)
counter = counter + 1
resultArr(counter, 1) = storesArr(y, 1)
resultArr(counter, 2) = yearArr(counter2, 1)
resultArr(counter, 3) = yearArr(counter2, 2)
Next y
Next x
wsSource.Range("A2").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
End Sub
Columns A, D and E are date and time.
I am trying to find out how many times the date in Column A falls between the start dates and end dates.
Column A may vary between 30 and 60 days while the start and end dates run to thousands.
Two questions:
Why am I receiving error Variable Not defined with the code below?
If cell A2 is date and time 24Feb17 12H00 then what formula do I put in cell A3 so that it reads 25Feb17 12H00 and so on?
Code:
Option Explicit
Sub DaysCount()
Dim endRow As Long
Dim LastRow As Long
Dim ICount As Long
Dim Day() As Variant
Dim StartDate() As Variant
Dim EndDate() As Variant
ICount = 0
With ThisWorkbook.Worksheets("sheet1")
LastRow = .Range("A" & .Rows.count).End(xlUp).Row
endRow = .Range("D" & .Rows.count).End(xlUp).Row
Day = Sheet1.Range("A2:A" & LastRow)
StartDate = Sheet1.Range("D2:D" & endRow)
EndDate = Sheet1.Range("E2:E" & endRow)
For i = LBound(StartDate) To UBound(StartDate)
For J = LBound(Day) To UBound(Day)
If Day(J, 1) >= StartDate(i, 1) And Day(J, 1) <= EndDate(i, 1) Then
ICount = ICount + 1
Else
End If
Sheet1.Range("B" & J).Value = ICount
Next i
ICount = 0
Next J
End With
End Sub
Option Explicit forces you to declare all variables, so you need to declare i and j too.
And your Next i and Next j weren't in the good order!
VBA : DateAdd("d",.Range("A3"),1)
Corrected code:
Option Explicit
Sub DaysCount()
Dim i As Long
Dim j As Long
Dim endRow As Long
Dim LastRow As Long
Dim ICount As Long
Dim Day() As Variant
Dim StartDate() As Variant
Dim EndDate() As Variant
ICount = 0
With ThisWorkbook.Worksheets("sheet1")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
endRow = .Range("D" & .Rows.Count).End(xlUp).Row
Day = Sheet1.Range("A2:A" & LastRow)
StartDate = Sheet1.Range("D2:D" & endRow)
EndDate = Sheet1.Range("E2:E" & endRow)
For i = LBound(Day) To UBound(Day)
For j = LBound(StartDate) To UBound(StartDate)
If Day(j, 1) >= StartDate(i, 1) And Day(j, 1) <= EndDate(i, 1) Then
ICount = ICount + 1
Else
End If
Next j
.Range("B" & i).Value = ICount
ICount = 0
Next i
End With
End Sub
I have an issue which I use a lot of manual time on currently.
I have following simple data:
And I wish to convert all the accounts downwards with the name next to the accounts in another column. Currently I do this by using the 'text to columns' function and then manually copy the names down.. HARD work.. :)
This is an example of my wish scenario..
Hope you are able to help..
Thanks a lot
Kristoffer
The following short macro will take data from Sheet1 and output records in Sheet2:
Sub DataReorganizer()
Dim i As Long, j As Long, N As Long
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 2 To N
v1 = s1.Cells(i, 1)
ary = Split(s1.Cells(i, 2), ";")
For Each a In ary
s2.Cells(j, 1).Value = v1
s2.Cells(j, 2).Value = a
j = j + 1
Next a
Next i
End Sub
Input:
and output:
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Cells(1, 1).CurrentRegion
Set rng = rng.Offset(1)
Set rng = rng.Resize(rng.Rows.Count - 1)
Dim vPaste
Dim lTotalRows As Long
Dim lPass As Long
For lPass = 0 To 1
Dim rowLoop As Excel.Range
For Each rowLoop In rng.Rows
Dim sName As String
sName = rowLoop.Cells(1, 1)
Dim sAccounts As String
sAccounts = rowLoop.Cells(1, 2)
Dim vSplitAccounts As Variant
vSplitAccounts = VBA.Split(sAccounts, ";")
If lPass = 0 Then
lTotalRows = lTotalRows + UBound(vSplitAccounts) + 1
Else
Dim vLoop As Variant
For Each vLoop In vSplitAccounts
lTotalRows = lTotalRows + 1
vPaste(lTotalRows, 1) = sName
vPaste(lTotalRows, 2) = vLoop
Next vLoop
End If
Next
If lPass = 0 Then
ReDim vPaste(1 To lTotalRows, 1 To 2)
lTotalRows = 0
End If
Next
ThisWorkbook.Worksheets.Item(2).Cells(1, 1).Value = "Name"
ThisWorkbook.Worksheets.Item(2).Cells(1, 2).Value = "Account"
Dim rngPaste As Excel.Range
Set rngPaste = ThisWorkbook.Worksheets.Item(2).Cells(2, 1).Resize(lTotalRows, 2)
rngPaste.Value2 = vPaste
End Sub
Not really good at VBA here. Found and edited some code that I believe can help me.
I need this code to search 2 columns (L and M) for any string in those columns that ends with _LC _LR etc... Example: xxxxxxxx_LC .
If the cell ends with anything in the array, I need the row to be copied to a new sheet. Here is what I have:
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("L2:L, M2:M" & lngLstRow)
For i = 1 To maxKeywords
If keywords(i) = rngCell.Value Then
rngCell.EntireRow.Copy
Sheets("sheet1").Select
Range("L65536, M65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Results").Select
End If
Next i
Next
End Sub
Okay, the issue I think is with your variable declarations. Before I continue, I will echo #GradeEhBacon's comment that if you can't read this and understand what's going on, you may want to take some time to learn VBA before running.
This should work, AFAIK. You didn't specify which sheet has what info, so that may have to be tweaked. Try the below, and let me know what is/isn't working:
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String, maxKeywords() As String
Dim totalKeywords As Integer, i&
Dim ws As Worksheet, resultsWS As Worksheet
Set ws = Sheets("Sheet1")
Set resultsWS = Sheets("Results")
totalKeywords = 6
ReDim keywords(1 To totalKeywords)
ReDim maxKeywords(1 To totalKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ws.UsedRange.Rows.Count 'Assuming "Sheet1" is what you want to get the last range of.
Dim k& ' create a Long to use as Column numbers for the loop
For k = 12 To 13 ' 12 is column L, 13 is M
With ws 'I'm assuming your Ranges are on the "Sheet1" worksheet
For Each rngCell In .Range(.Cells(1, k), .Cells(lngLstRow, k))
For i = LBound(maxKeywords) To UBound(maxKeywords)
If maxKeywords(i) = Right(rngCell.Value, 3) or maxKeywords(i) = Right(rngCell.Value, 2) Then
' rngCell.EntireRow.Copy
' ws.Range("L65536, M65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
resultsWS.Cells(65536, k).End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value
End If
Next i
Next rngCell
End With
Next k
End Sub
This might be what you are looking for:
==================================================
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords, i, j, k As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
keywords(1) = "_LC"
keywords(2) = "_LR"
keywords(3) = "_LF"
keywords(4) = "_W"
keywords(5) = "_R"
keywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For j = 1 To lngLstRow
For i = 1 To maxKeywords
If keywords(i) = Right(Sheets("Results").Range("L" & j).Value, Len(keywords(i))) Or _
keywords(i) = Right(Sheets("Results").Range("M" & j).Value, Len(keywords(i))) Then
k = k + 1
Rows(j & ":" & j).Copy
Sheets("sheet1").Select
Range("A" & k).Select
ActiveSheet.Paste
End If
Next i
Next j
End Sub