Loop to copy values from one sheet to another - excel

I have 2 sheets, sourcesheet and acct sheet. From sourceSheet I need to copy the values from sourceSheet.Range(Cells(14, 3),Cells(14, 8)) to AcctSheet.range(Cells(2, 11),Cells(7, 11)), however each cell from sourcesheet is distinct matched to acctsheet, in such a way that
sourceSheet.Cells(14, 3) = AcctSheet.Cells(2, 11)
sourceSheet.Cells(14, 4) = AcctSheet.Cells(3, 11)
sourceSheet.Cells(14, 5) = AcctSheet.Cells(4, 11) and so on until
sourceSheet.Cells(14, 8) = AcctSheet.Cells(7, 11)
Code is here, but hoping to loop this one.
sourceSheet.Activate
'EQ
If IsEmpty(sourceSheet.Cells(14, 3).Value) Then
AcctSheet.Cells(2, 11).Value = sourceSheet.Cells(7, 1).Value
ElseIf sourceSheet.Cells(14, 3).Value < sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(2, 11).Value = sourceSheet.Cells(14, 3).Value
ElseIf sourceSheet.Cells(14, 3).Value > sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(2, 11).Value = sourceSheet.Cells(7, 1).Value
End If
'WS
If IsEmpty(sourceSheet.Cells(14, 4).Value) Then
AcctSheet.Cells(3, 11).Value = sourceSheet.Cells(7, 1).Value
ElseIf sourceSheet.Cells(14, 4).Value < sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(3, 11).Value = sourceSheet.Cells(14, 4).Value
ElseIf sourceSheet.Cells(14, 4).Value > sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(3, 11).Value = sourceSheet.Cells(7, 1).Value
End If
'TO
If IsEmpty(sourceSheet.Cells(14, 5).Value) Then
AcctSheet.Cells(4, 11).Value = sourceSheet.Cells(7, 1).Value
ElseIf sourceSheet.Cells(14, 5).Value < sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(4, 11).Value = sourceSheet.Cells(14, 5).Value
ElseIf sourceSheet.Cells(14, 5).Value > sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(4, 11).Value = sourceSheet.Cells(7, 1).Value
End If
'FL
If IsEmpty(sourceSheet.Cells(14, 6).Value) Then
AcctSheet.Cells(5, 11).Value = sourceSheet.Cells(7, 1).Value
ElseIf sourceSheet.Cells(14, 6).Value < sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(5, 11).Value = sourceSheet.Cells(14, 6).Value
ElseIf sourceSheet.Cells(14, 6).Value > sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(5, 11).Value = sourceSheet.Cells(7, 1).Value
End If
'FR
If IsEmpty(sourceSheet.Cells(14, 7).Value) Then
AcctSheet.Cells(6, 11).Value = sourceSheet.Cells(7, 1).Value
ElseIf sourceSheet.Cells(14, 7).Value < sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(6, 11).Value = sourceSheet.Cells(14, 7).Value
ElseIf sourceSheet.Cells(14, 7).Value > sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(6, 11).Value = sourceSheet.Cells(7, 1).Value
End If
'TR
If IsEmpty(sourceSheet.Cells(14, 8).Value) Then
AcctSheet.Cells(7, 11).Value = sourceSheet.Cells(7, 1).Value
ElseIf sourceSheet.Cells(14, 8).Value < sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(7, 11).Value = sourceSheet.Cells(14, 8).Value
ElseIf sourceSheet.Cells(14, 8).Value > sourceSheet.Cells(7, 1).Value Then
AcctSheet.Cells(7, 11).Value = sourceSheet.Cells(7, 1).Value
End If

Is something like this what you are looking for?
Option Explicit
Sub test()
Dim sourceSheet As Worksheet, acctSheet As Worksheet
Dim i As Long
Dim sourceCell As Range, targetCell As Range, defaultCell As Range
Set defaultCell = sourceSheet.Cells(7, 1)
For i = 3 To 8
Set sourceCell = sourceSheet.Cells(14, i)
Set targetCell = acctSheet.Cells(i - 1, 11)
If IsEmpty(sourceCell) Then
targetCell.Value2 = sourceCell.Value2
ElseIf sourceCell.Value2 < defaultCell.Value2 Then
targetCell.Value2 = sourceCell.Value2
ElseIf sourceCell.Value2 > defaultCell.Value2 Then
targetCell.Value2 = defaultCell.Value2
End If
Next i
End Sub
Strictly speaking, I don't think you need to include .Value2 after every cell, as VBA kinda uses that as the default when reading the code, but it doesn't hurt.
Using variables for the cell references isn't strictly necessary either, but I find it easier, especially if I need to edit the cell references later.

Related

Editing Excel from Access VBA Object Required Error

I have a program that opens an Excel spreadsheet and makes changes to it. I am always editing the first sheet but if it is a certain type of report I want to edit the second sheet as well. This all works fine for me on the first sheet and all but centering the text in the cell on the second sheet. I get an Object Required error only when I try to do this. I center the text in the cells on the first sheet no problem. The error only comes after I pass the object to the new procedure. Here is some of my code:
First Procedure
Private Sub OSummary1(strfile As String, strTableResults As String, dtUnivDt As Date)
Dim xlApp As Object
Dim objWorkbook As Object
Dim objSheet As Object
Set xlApp = CreateObject("Excel.Application")
Set objWorkbook = xlApp.Workbooks.Open(strfile)
Set objSheet = objWorkbook.Sheets(1)
Later in the code
ElseIf Mid(strTableResults, 11, 1) = 1 Then
Max = 11
Do Until i > Max
If .Cells(i, 4).Value = "0" And .Cells(i, 2).Value = "0" And .Cells(i, 3).Value = "0" Then
.Cells(i, 4).Value = "NA"
.Cells(i, 4).Interior.ColorIndex = 15
.Cells(i, 3).Value = "-"
.Cells(i, 2).Value = "-"
ElseIf .Cells(i, 2).Value = "0" Then
.Cells(i, 4).Value = "0.0"
.Cells(i, 4).Interior.ColorIndex = 22
ElseIf .Cells(i, 4).Value >= "95.00" Or .Cells(i, 4).Value = "100" Then
.Cells(i, 4).Interior.ColorIndex = 43
ElseIf .Cells(i, 4).Value >= "90.00" And .Cells(i, 4).Value < "95.00" Then
.Cells(i, 4).Interior.ColorIndex = 36
Else
.Cells(i, 4).Interior.ColorIndex = 22
End If
If .Cells(i, 4).Value = 0 Then
.Cells(i, 4).NumberFormat = "0.00%"
ElseIf Not .Cells(i, 4).Value Like "*.*" Then
.Cells(i, 4).NumberFormat = "#.00""%"""
ElseIf .Cells(i, 4).Value Like "*.#" Then
.Cells(i, 4).NumberFormat = "#.#0""%"""
Else
.Cells(i, 4).NumberFormat = "#.##""%"""
End If
If .Cells(i, 1).Value = "AppealNotificationTimeliness" Then
.Cells(i, 1).Font.Bold = True
.Cells(i, 2).Font.Bold = True
.Cells(i, 3).Font.Bold = True
.Cells(i, 4).Font.Bold = True
.Cells(i, 2).HorizontalAlignment = xlCenter
.Cells(i, 3).HorizontalAlignment = xlCenter
.Cells(i, 4).HorizontalAlignment = xlCenter
iB = Len(.Cells(i, 2).Value)
iC = Len(.Cells(i, 3).Value)
iD = .Cells(i, 4).Value
Else
'Indent header
.Cells(i, 1).IndentLevel = 3
'Indent sub-headers
If iB < 3 Then
.Cells(i, 2).IndentLevel = 5
ElseIf iB > 2 And iB < 5 Then
.Cells(i, 2).IndentLevel = 4
ElseIf iB > 4 And iB < 7 Then
.Cells(i, 2).IndentLevel = 3
Else
.Cells(i, 2).IndentLevel = 2
End If
If iC < 3 Then
.Cells(i, 3).IndentLevel = 4
ElseIf iC > 2 And iC < 5 Then
.Cells(i, 3).IndentLevel = 3
ElseIf iC > 4 And iC < 7 Then
.Cells(i, 3).IndentLevel = 2
Else
.Cells(i, 3).IndentLevel = 1
End If
If iD = "NA" Then
.Cells(i, 4).IndentLevel = 5
ElseIf iD = "100" Then
.Cells(i, 4).IndentLevel = 3
Else
.Cells(i, 4).IndentLevel = 4
End If
End If
i = i + 1
Loop
If Right(strTableResults, 3) = "FDR" Then
Call FDRTable1(objWorkbook)
End If
This all works fine for sheet 1
Second Procedure from Call above
Private Sub FDRTable1(ByRef objWorkbook As Object)
Dim objSheet As Object
Dim RowCnt As Integer
Dim CurrentRow As Integer
Dim CurrentRowVal As String
Dim iRange As Range
Dim iCells As Range
Dim i As Integer
Dim Max As Integer
Set objSheet = objWorkbook.Sheets(2)
i = 2
With objSheet
'Header
.Cells(1, 1).Font.Size = 12
.Range("A1:G1").Font.Bold = True
.Cells.EntireColumn.AutoFit
.Range("A2:G6").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Range("A7:G9").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Range("A10:G14").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Range("A15:G17").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Max = 17
Do Until i > Max
If .Cells(i, 7).Value = "0" And .Cells(i, 4).Value = "0" And .Cells(i, 6).Value = "0" Then
.Cells(i, 7).Value = "NA"
.Cells(i, 7).Interior.ColorIndex = 15
.Cells(i, 4).Value = "-"
.Cells(i, 5).Value = "-"
.Cells(i, 6).Value = "-"
ElseIf .Cells(i, 4).Value = "0" Then
.Cells(i, 7).Value = "0.0"
.Cells(i, 7).Interior.ColorIndex = 22
ElseIf .Cells(i, 7).Value >= "95.00" Or .Cells(i, 7).Value = "100" Then
.Cells(i, 7).Interior.ColorIndex = 43
ElseIf .Cells(i, 7).Value >= "90.00" And .Cells(i, 7).Value < "95.00" Then
.Cells(i, 7).Interior.ColorIndex = 36
Else
.Cells(i, 7).Interior.ColorIndex = 22
End If
If .Cells(i, 7).Value = 0 Then
.Cells(i, 7).NumberFormat = "0.00%"
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
ElseIf Not .Cells(i, 7).Value Like "*.*" Then
.Cells(i, 7).NumberFormat = "#.00""%"""
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
ElseIf .Cells(i, 7).Value Like "*.#" Then
.Cells(i, 7).NumberFormat = "#.#0""%"""
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
Else
.Cells(i, 7).NumberFormat = "#.##""%"""
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
End If
i = i + 1
Loop
End With
End Sub
This all works too except I get the error when I try to center the text (.HorizontalAlignment.xlCenter). If I remove those lines, it works fine.

Populate listbox with headers

I am trying to populate a listbox from a list of items, I can get it to populate but it is taking in my header row as a row in the list and the headers are blank. I am not sure where I am going wrong. Any help would be great.
Sub populateList()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("ProjectData")
lbTasks.Clear
lbTasks.ColumnHeads = True
lbTasks.ColumnCount = 10
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
If ws.Cells(i, 1).Value <> vbNullString Then lbTasks.AddItem ws.Cells(i, 1).Value
If ws.Cells(i, 2).Value <> vbNullString Then lbTasks.List(i - 1, 1) = ws.Cells(i, 2).Value
If ws.Cells(i, 3).Value <> vbNullString Then lbTasks.List(i - 1, 2) = ws.Cells(i, 3).Value
If ws.Cells(i, 4).Value <> vbNullString Then lbTasks.List(i - 1, 3) = ws.Cells(i, 4).Value
If ws.Cells(i, 5).Value <> vbNullString Then lbTasks.List(i - 1, 4) = ws.Cells(i, 5).Value
If ws.Cells(i, 6).Value <> vbNullString Then lbTasks.List(i - 1, 5) = ws.Cells(i, 6).Value
If ws.Cells(i, 7).Value <> vbNullString Then lbTasks.List(i - 1, 6) = ws.Cells(i, 7).Value
If ws.Cells(i, 8).Value <> vbNullString Then lbTasks.List(i - 1, 7) = ws.Cells(i, 8).Value
If ws.Cells(i, 9).Value <> vbNullString Then lbTasks.List(i - 1, 8) = ws.Cells(i, 9).Value
If ws.Cells(i, 10).Value <> vbNullString Then lbTasks.List(i - 1, 9) = ws.Cells(i, 10).Value
Next i
End Sub

Pasting the values with the format in with, as the date format changes every time

I am trying to copy the values of a date from the sheet "Create new Customer" to "Customer data" and every time the date format changes
strName = Sheets("Create_New_Customer").Cells(14, 4).Value
strAddress = Sheets("Create_New_Customer").Cells(15, 4).Value
strTown = Sheets("Create_New_Customer").Cells(16, 4).Value
strPostcode = Sheets("Create_New_Customer").Cells(17, 4).Value
strTel = Sheets("Create_New_Customer").Cells(18, 4).Value
strEmail = Sheets("Create_New_Customer").Cells(19, 4).Value
strEqMk = Sheets("Create_New_Customer").Cells(20, 4).Value
strEqMdl = Sheets("Create_New_Customer").Cells(21, 4).Value
strEqType = Sheets("Create_New_Customer").Cells(22, 4).Value
strEqCost = Sheets("Create_New_Customer").Cells(23, 4).Value
strRentalStartDate = Sheets("Create_New_Customer").Cells(24, 4).Value
strCond = Sheets("Create_New_Customer").Cells(25, 4).Value
strPayT = Sheets("Create_New_Customer").Cells(26, 4).Value
strMonthRentalCost = Sheets("Create_New_Customer").Cells(27, 4).Value
strPaymentMehtod = Sheets("Create_New_Customer").Cells(28, 4).Value
With Sheets("CustomersData")
.Cells(LastRow, 2).Value = strName
.Cells(LastRow, 3).Value = strAddress
.Cells(LastRow, 4).Value = strTown
.Cells(LastRow, 5).Value = strPostcode
.Cells(LastRow, 6).Value = strTel
.Cells(LastRow, 7).Value = strEmail
.Cells(LastRow, 8).Value = strEqMk
.Cells(LastRow, 9).Value = strEqMdl
.Cells(LastRow, 10).Value = strEqType
.Cells(LastRow, 11).Value = strEqCost
.Cells(LastRow, 12).Value = strRentalStartDate
.Cells(LastRow, 13).Value = strCond
.Cells(LastRow, 14).Value = strPayT
.Cells(LastRow, 15).Value = strMonthRentalCost
.Cells(LastRow, 16).Value = strPaymentMehtod
End With

if statments with "AND , OR"

please i need help on this code: it compares different values in different column at the same row level and executes the "then statement". But the code i wrote doesn't real function as i expected.
Sub Z_status()
Dim wsO As Worksheet
Set wsO = Sheets("Sending List")
Dim i As Long
Dim Lastrow As Long
With wsO
Lastrow = Cells(Rows.Count, 5).End(xlUp).Row
'Lastrow_2 = Cells(Rows.Count, 6).End(xlUp).Row
'Lastrow_3 = Cells(Rows.Count, 3).End(xlUp).Row
'Lastrow_4 = Cells(Rows.Count, 8).End(xlUp).Row
For i = Lastrow To 2 Step -1
'For j = Lastrow_2 To 2 Step -1
'For k = Lastrow_3 To 2 Step -1
'For l = Lastrow_3 To 2 Step -1
Cells(1, 7).Value = "Expected state"
If (Cells(i, 5).Value = "MTS" Or Cells(i, 5).Value = "MTO") And (Cells(i, 6).Value = "1/1/1900" Or Cells(i, 6).Value > Date) And (Cells(i, 3).Value = 0) And (Cells(i, 8).Value = 0) Then
Cells(i, 7).Value = "Z1"
ElseIf (Cells(i, 5).Value = "MTS" Or Cells(i, 5).Value = "MTO") And (Cells(i, 6).Value = "1/1/1900" Or Cells(i, 6).Value > Date) And (Cells(i, 3).Value = 0) And (Cells(i, 8).Value > 0 Or Cells(i, 8).Value = 0) Then
Cells(i, 7).Value = "Z3"
ElseIf (Cells(i, 5).Value = "MTS" Or Cells(i, 5).Value = "MTO") And (Cells(i, 6).Value = "1/1/1900" Or Cells(i, 6).Value > Date) And (Cells(i, 3).Value > 0) And (Cells(i, 8).Value > 0 Or Cells(i, 8).Value = 0) Then
Cells(i, 7).Value = "Z5"
ElseIf (Cells(i, 5).Value = "Obsolete") And (Cells(i, 6).Value < Date) And (Cells(i, 3).Value > 0) And (Cells(i, 8).Value > 0 Or Cells(i, 8).Value = 0) Then
Cells(i, 7).Value = "Z7"
ElseIf (Cells(i, 5).Value = "Obsolete") And (Cells(i, 6).Value < Date) And (Cells(i, 3).Value = 0) And (Cells(i, 8).Value = 0) Then
Cells(i, 7).Value = "Z9"
End If
Next i
' Next j
' Next k
' Next l
End With
End Sub
1 Your conditions for Z3 and z5 are identical
2 You can write
(Cells(i, 8).Value > 0 Or Cells(i, 8).Value = 0)
as (Cells(i, 8).Value >= 0 )
Your ifs can be written more clearly as
If (Cells(i, 5).Value = "MTS" Or Cells(i, 5).Value = "MTO") And (Cells(i, 6).Value = "1/1/1900" Or Cells(i, 6).Value > Date) Then
If (Cells(i, 8).Value = 0) Then
Cells(i, 7).Value = "Z1"
Else
If (Cells(i, 8).Value > 0) Then
Cells(i, 7).Value = "Z5"
End If
End If
Else
If (Cells(i, 5).Value = "Obsolete") Then
If (Cells(i, 6).Value < Date) And (Cells(i, 8).Value >= 0) Then
If (Cells(i, 3).Value > 0) Then
Cells(i, 7).Value = "Z7"
Else
If (Cells(i, 3).Value = 0) Then
Cells(i, 7).Value = "Z9"
Else
'This case is undefined
End If
End If
Else
'This case is undefined
End If
Else
'this case is undefined
End If
End If
Hopefully you can work out the errors more easily in this form

multiple errors when attempting to make user form input to excel cells

I am trying to make a userform with checkboxes, combo boxes text input into the cells of the next row of the excel sheet. I've tried so many ways to make it work but it won't input:
Private Sub CommandButton1_Click()
Dim rowcount As Long
Dim ws As worksheet
Set ws = Worksheets("Raw Data")
rowcount = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
With ws
.Cells(rowcount, 0).Value = Me.TextBox1.Value
.Cells(rowcount, 1).Value = Me.TextBox2.Value
.Cells(rowcount, 2).Value = Me.TextBox3.Value
.Cells(rowcount, 3).Value = Me.TextBox4.Value
.Cells(rowcount, 4).Value = Me.TextBox5.Value
.Cells(rowcount, 5).Value = Me.TextBox6.Value
.Cells(rowcount, 6).Value = Me.TextBox7.Value
.Cells(rowcount, 7).Value = Me.TextBox8.Value
.Cells(rowcount, 8).Value = Me.TextBox9.Value
.Cells(rowcount, 9).Value = Me.TextBox10.Value
.Cells(rowcount, 10).Value = Me.PNBox.Value
.Cells(rowcount, 11).Value = Me.ENBox.Value
.Cells(rowcount, 12).Value = Me.CheckBox4.Value
.Cells(rowcount, 13).Value = Me.CheckBox5.Value
.Cells(rowcount, 14).Value = Me.CheckBox6.Value
.Cells(rowcount, 15).Value = Me.CheckBox7.Value
.Cells(rowcount, 19).Value = Me.CheckBox11.Value
.Cells(rowcount, 20).Value = Me.CheckBox12.Value
.Cells(rowcount, 21).Value = Me.CheckBox13.Value
.Cells(rowcount, 22).Value = Me.CheckBox14.Value
I want to make each variable show up on the next column on the sheet and blanks or false items to stay blank.

Resources