I have the vba code below in Excel that almost works. I'm having an issue where the "firstrow" isn't increasing. The first file will contain rows 1-501, the second file will contain 1-1001 (I want it to contain row 1 & 502-1001). I'm sure it's a small issue but I've stared at it for a while and can't seem to figure out whats wrong. Some help would be really awesome!!
Sub FiveHundredLineCopy()
Dim Firstrow As Integer
Dim Lastrow As Integer
Dim Copyrange As String
Dim Startcell As String
Dim Month, Year As String
Firstrow = 2 'Starts on row 2 to exclude header
Lastrow = Firstrow + 499
Month = Nov 'Month of Clinic for filename
Year = 2014 'Year of Clinic for filename
Filenumber = 1 'First file in sequence
Let Startcell = "A" & Firstrow
Let Copyrange = "A" & Firstrow & ":" & "BZ" & Lastrow 'Only copying through column BZ
Do While Range(Startcell) <> ""
Range("A1:BZ1", Copyrange).Copy 'Includes A1:BZ1 to copy header row as well
Set NewBook = Workbooks.Add
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
NewBook.SaveAs Filename:=Range("AJ2").Text & "_Sams_Apex_" & Month & " " & Year & "_File " & Filenumber & ".csv", FileFormat:=xlCSV
NewBook.Close Savechanges:=False
Firstrow = Firstrow + 500
Lastrow = Firstrow + 499
Filenumber = Filenumber + 1
Let Startcell = "A" & Firstrow
Let Copyrange = "A" & Firstrow & ":" & "BZ" & Lastrow
Loop
End Sub
The Range(Cell1, Cell2) selects the cells starting from Cell1 through Cell2. You can copy and paste the header first and then the Copyrange you want after the fact.
You are extending the Copyrange from the header row to the last row that you want to copy. As mentioned, you could run two operations or hide the rows that have already been copied.
Do While Range(Startcell) <> ""
Range("A1:BZ1", Copyrange).Copy 'Includes A1:BZ1 to copy header row as well
Set NewBook = Workbooks.Add
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
NewBook.SaveAs Filename:=Range("AJ2").Text & "_Sams_Apex_" & Month & " " & Year & "_File " & Filenumber & ".csv", FileFormat:=xlCSV
NewBook.Close Savechanges:=False
'hide the ones already copied. hidden rows will not be copied to the new location
copyrange.resize(copyrange.rows.count - 1, copyrange.columns.count).offset(1, 0).entirerow.hidden = true
Firstrow = Firstrow + 500
Lastrow = Firstrow + 499
Filenumber = Filenumber + 1
Let Startcell = "A" & Firstrow
Let Copyrange = "A" & Firstrow & ":" & "BZ" & Lastrow
Loop
Don't forget to unhide all of the rows after the splitting operation has completed.
Related
Below is a code that I am now using to automatically insert numbers to a cell that has todays date on Column A and the correct name on the first row of that column.
However, I can't seem to make it work if the names are in any other row than 1.
What changes do I need to make if I want it to search matches on row 2 or multiple rows?
Sub SyöttöEriVälilehti()
Application.ScreenUpdating = False
On Error GoTo M
Dim i As Long
Dim Lastrow As Long
Dim col As Long
col = 0
Dim LastColumn As Long
Dim DateLastrow As Long
Dim ans As String
Dim LString As String
Dim LArray() As String
Dim anss As String
Dim ansss As String
With Sheets("Malli2Data") ' Sheet name
DateLastrow = .Cells(Rows.Count, "A").End(xlUp).Row
Set SearchRange = .Range("A1:A" & DateLastrow).Find(Date)
If SearchRange Is Nothing Then MsgBox Date & " No matches", , "Oops!": Exit Sub
Lastrow = SearchRange.Row
LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
ans = InputBox("Input name and number like so: Tom,5")
LString = ans
LArray = Split(LString, ",")
anss = LArray(0)
ansss = LArray(1)
For i = 2 To LastColumn
If .Cells(1, i).Value = anss Then col = Cells(1, i).Column
Next
If col = 0 Then MsgBox anss & " No matches": Exit Sub
.Cells(Lastrow, col).Value = ansss
End With
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "Error" & vbNewLine _
& "Check input" & _
vbNewLine & "You typedt: " & ans & vbNewLine & "Correct input type: " & vbNewLine & "Name" & ",Number" & _
vbNewLine & vbNewLine & "Try again"
End Sub
The snippet:
For i = 2 To LastColumn
If .Cells(1, i).Value = CDec(anss) Then col = Cells(1, i).Column
Next
Is searching row 1 for your name
If you want to change it and make it a variable, something like
For i = 2 To LastColumn
If .Cells(xRow, i).Value = CDec(anss) Then col = Cells(1, i).Column
Next
With xRow being your defined row to search will work.
At the same time, you could sub out the last bit within the loop and use
For i = 2 To LastColumn
If .Cells(xRow, i).Value = CDec(anss) Then col = i
Next
As they are the same thing.
edit 20201-04-23A: Use of CDec(anss) will convert the string (as gathered from "ans") into a decimal number - which can then be compared against the .Value taken out of the cell.
I know very little about VBA code, but I can follow along the lines of logic in a given example. So I googled and found a code I edited to highlight duplicates in a worksheet. However, I have a workbook with three sheets. I would like to adapt this to compare sheet 1 and sheet 3, then highlight the duplicates in sheet 1.
Sub Highlight_Dups()
Dim startRow As Integer
startRow = 2
Dim row As Integer
row = startRow
Do While (Range("A" & row).Value <> "")
Dim innerRow As Integer
innerRow = row + 1
Dim StudentID As String
Dim DT As String
Dim Description As String
StudentID = Range("A" & row).Value
DT = Range("H" & row).Value
Description = Range("J" & row).Value
Do While (Range("A" & innerRow).Value <> "")
If (Range("A" & innerRow).Value = StudentID And Range("H" & innerRow).Value = DT And Range("J" & innerRow).Value = Description) Then
Range("X" & row).Value = Range("X" & row).Value & innerRow & ", "
Range("X" & innerRow).Value = Range("X" & innerRow).Value & row & ", "
Rows(row).Interior.ColorIndex = 6
Rows(innerRow).Interior.ColorIndex = 6
End If
innerRow = innerRow + 1
Loop
row = row + 1
Loop
MsgBox "done", vbOKOnly, "done"
End Sub
Any help on how to add ???= Sheets("Sheet1") and ??? = Sheets("Sheet3")
would help me a great deal. Thanks
You might want to consider discarding the laborious task of looping through every cell while comparing it to every other and use a pair of conditional formatting rules.
Option Explicit
Private Sub cfrS1S3dupes()
With ThisWorkbook.Worksheets("sheet1")
With .Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "J"))
'get rid of pre-existing cfrs
.FormatConditions.Delete
'if duplicate in sheet1 found below row, then fill red
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=countifs($a$2:$a2, $a2, $h$2:$h2, $h2, $j$2:$j2, $j2)>1")
.Interior.Color = 255 'this is the color red
End With
'if duplicate anywhere in sheet3, then fill green
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=countifs(sheet3!$a:$a, $a2, sheet3!$h:$h, $h2, sheet3!$j:$j, $j2)")
.Interior.Color = 5287936 'this is the color green
End With
End With
End With
End Sub
First of all, you should declare 2 sheet objects to make it easier to read and future code maintences easier:
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'use this approach if your sheet's name is dinamic but never changes it's order
'Set ws1 = ThisWorkbook.Sheets(1)
'Set ws2 = ThisWorkbook.Sheets(2)
'use this if name is static
Set ws1 = ThisWorkbook.Sheets("name of worksheet1")
Set ws2 = ThisWorkbook.Sheets("name of worksheet2")
Then just put the Sheets objects in their specific locations like this (pay attention to the 'ws1's and 'ws2's):
Dim StudentID As String
Dim DT As String
Dim Description As String
Do While (ws1.Range("A" & Row).Value <> "")
innerRow = Row + 1
StudentID = ws1.Range("A" & Row).Value
DT = ws1.Range("H" & Row).Value
Description = ws1.Range("J" & Row).Value
Do While (ws2.Range("A" & innerRow).Value <> "")
If (ws2.Range("A" & innerRow).Value = StudentID And ws2.Range("H" & innerRow).Value = DT And ws2.Range("J" & innerRow).Value = Description) Then
'not sure what you are trying to do with this 3 lines, change it for your own needs
ws1.Range("X" & Row).Value = ws2.Range("X" & Row).Value & innerRow & ", "
ws1.Range("X" & innerRow).Value = ws2.Range("X" & innerRow).Value & Row & ", "
ws1.Rows(Row).Interior.ColorIndex = 6
ws1.Rows(innerRow).Interior.ColorIndex = 6
End If
innerRow = innerRow + 1
Loop
Row = Row + 1
Loop
End Sub
ps: i couldn't test it since you didn't provide the base of yours. But since you said you can read code and understand it's logic, I think you'll be fine :)
We have a macro working via a button in Excel 2013 to insert a new row with formula from above. the Problem is when it runs and i say for example copy from row 10 the formula in the new row 11 all still read back to row 10 not 11?
Sub Loop_InsertRowsandFormulas()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Risk Input Sheet")
Dim vRows As Long
Dim lastCol As Long
Dim firstRow As Long
firstRow = InputBox("Enter Row To Start Insert From.")
vRows = InputBox("Enter Number Of Rows Required")
If firstRow = 0 Or vRows = 0 Then Exit Sub
Debug.Print firstRow
IngA = ws.Cells(5, ws.Columns.Count).End(xlToLeft).Column
For myLoop = 1 To vRows
ws.Range("A" & (firstRow + myLoop)).EntireRow.Insert
ws.Range("A" & (firstRow + myLoop) & ":BB" & (firstRow + myLoop)).Formula = ws.Range("A" & firstRow & ":BB" & firstRow).Formula
Next
End Sub
You need to do a Copy/Paste. For example, if A1 contains:
=B1+C1
running:
Sub qwerty()
Range("A2").Formula = Range("A1").Formula
End Sub
will leave A2 with =B1+C1 as well.
If you want the copied formula to "adjust" then:
Sub ytrewq()
Range("A1").Copy Range("A2")
End Sub
EDIT#1:
Rather than:
ws.Range("A" & (firstRow + myLoop) & ":BB" & (firstRow + myLoop)).Formula = ws.Range("A" & firstRow & ":BB" & firstRow).Formula
use something like:
ws.Range("A" & firstRow & ":BB" & firstRow).Copy ws.Range("A" & (firstRow + myLoop) & ":BB" & (firstRow + myLoop))
Cannot take any praise for this. Thanks Dave.
Sub Loop_InsertRowsandFormulas()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Risk Input Sheet")
Dim vRows As Long
Dim lastCol As Long
Dim firstRow As Long
firstRow = InputBox("Enter Row To Start Insert From.")
vRows = InputBox("Enter Number Of Rows Required")
If firstRow = 0 Or vRows = 0 Then Exit Sub
Debug.Print firstRow
IngA = ws.Cells(5, ws.Columns.Count).End(xlToLeft).Column
For Myloop = 1 To vRows
ws.Range("A" & (firstRow + Myloop)).EntireRow.Insert
ws.Range("N" & (firstRow) & ":AW" & (firstRow + Myloop)).FillDown
Next
End Sub
I have an excel sheet which need do format the data
I need to format this data like this in different sheet
Note - This a small sample I created for your understanding
my test macro is below. If you want to use it, you just need to rename your sheets - "DataSheet" for the one with the data and "ResultSheet" where the result will be stored.
Sub Reformat()
Dim letter As String
Dim iRow As Integer
Dim rng As Excel.Range
Sheets("ResultSheet").Range("A1:A" & Range("A1").End(xlDown).Row).Value = Range("A1:A" & Range("A1").End(xlDown).Row).Value
Sheets("ResultSheet").Select
Range("A1:A" & Range("A1").End(xlDown).Row).RemoveDuplicates Columns:=1, Header:=xlNo
Set rng = Range("A1:A" & Range("A1").End(xlDown).Row)
For i = 1 To Sheets("DataSheet").Range("A1").End(xlDown).Row
letter = Sheets("DataSheet").Range("A" & i).Value
iRow = WorksheetFunction.Match(letter, rng)
If Range("B" & iRow).Value = "" Then
Range("B" & iRow).Value = Sheets("DataSheet").Range("B" & i).Value
Else
Range("A" & iRow).End(xlToRight).Offset(0, 1).Value = Sheets("DataSheet").Range("B" & i).Value
End If
Next i
End Sub
I have three columns of data. Is there a way using vba to insert the information into a label on a userForm?
Here is the updated code I have:
Dim rowNum As Integer
Dim lastRow As Integer
lastRow = 373
For rowNum = 2 To lastRow
report = Sheets("DATA2").Range("F" & rowNum).Text & _
" " & Sheets("DATA2").Range("G" & rowNum).Text & _
" " & Sheets("DATA2").Range("H" & rowNum).Text & vbCrLf
Next rowNum
End Sub
Try:
Dim rowNum as Integer 'loop counter
Dim lastRow as Integer
lastRow = 'some code to set the row number of the bottom row
For rowNum = 1 to lastRow
With ActiveWorksheet
myLabel.Text = myLabel.Text & .Range("A" & rowNum).Text & " " & .Range("B" & rowNum).Text & " " & .Range("C" & rowNum).Text & vbCrLf
End With
Next rowNum
EDIT
Updated to append each loop instead of over-writing
Assuming that your label can handle multiple lines, you could write a loop that iterates through each column of data and appends it to a String as a new line, and then set the text field of that label to the string you created.